'From Objectworks for Smalltalk-80(tm), Version 2.5 of 29 July 1989 on 10 April 1999 at 6:41:07 pm'! ((CxxSystemOrganization tree childNamed: 'top') ~= nil) ifTrue: [ (CxxSystemOrganization tree childNamed: 'top') destroyFiles]! Heaper subclass: #Abraham instanceVariableNames: ' myHash {UInt32} myToken {Int32 NOCOPY} myInfo {FlockInfo NOCOPY}' classVariableNames: ' DismantleStatistics {IdentityDictionary smalltalk of: Category and: IntegerVar} TheTokenSource {TokenSource} ' poolDictionaries: '' category: 'Xanadu-Snarf'! (Abraham getOrMakeCxxClassDescription) friends: 'friend class SnarfPacker; friend class TestPacker; friend class FakePacker; friend class SnarfRecord; friend class SnarfHandler; friend void unlockFunctionAvoidingDestroy (Abraham *); friend class RecorderHoister; '; attributes: ((Set new) add: #DEFERRED.LOCKED; add: #DEFERRED; add: #COPY; yourself)! !Abraham methodsFor: 'protected: destruction'! {void} becomeStub "Replace the shepherd in memory with a type compatible stub instance that shares the same hash and flockInfo." "NOTE: Should this ensure that the flock is not dirty?" "Each subclass of Abraham will have an implementation of the form: new (this) MyStubClass()' or: 'this->changeClassToThatOf(ProtoStubClass)'" [| theHash {UInt32} info {FlockInfo} theCategory {Category} | theHash _ myHash. info _ myInfo. theCategory _ self getCategory. (ShepherdStub new.Become: self) create: theHash with: info with: theCategory] smalltalkOnly. [self unimplemented] translateOnly! {void NOFAULT NOLOCK} destruct "Called when an object is leaving RAM. Additional behavior for subclasses of Abraham: Tell the snarfPacker that I am leaving RAM and should be removed from its tables." myInfo ~~ NULL ifTrue: [CurrentPacker fluidGet dropFlock: myToken]. super destruct! {void} dismantle "Disconnect me from the universe and throw me off the disk. For GC safety, we keep a strongptr to ourself -- is this still necessary?" | spt {Abraham} packer {DiskManager} | spt _ self. [| pos {Category} | pos _ self getCategory. DismantleStatistics at: pos put: (DismantleStatistics at: pos ifAbsent: [0]) + 1] smalltalkOnly. "Tell the disk the flock is dismantled." packer _ CurrentPacker fluidGet. packer dismantleFlock: myInfo. packer flockTable at: myToken store: NULL. myInfo ~~ NULL ifTrue: [packer dropFlock: myToken].! ! !Abraham methodsFor: 'protected: disk'! {void} diskUpdate "The receiver has changed and so must eventually be rewritten to disk." myInfo == NULL ifTrue: ["Before a newShepherd." CurrentPacker fluidGet storeAlmostNewShepherd: self] ifFalse: [CurrentPacker fluidGet diskUpdate: myInfo]! {void NOFAULT} forget "Record on disk that there are no more persistent pointers to the receiver. When the in core pointers go away, the receiver can be dismantled from disk. That will happen eventually." CurrentPacker fluidGet forgetFlock: myInfo! {void NOFAULT} newShepherd "The receiver has just been created. Put it on disk." CurrentPacker fluidGet storeNewFlock: self! {void NOFAULT} remember "Record that there are now persistent pointers to the receiver." CurrentPacker fluidGet rememberFlock: myInfo! ! !Abraham methodsFor: 'destruction'! {void} destroy "Tell the packer I want to go away. It will mark me as forgotten and actually dismantle me when it next exits a consistent block. This avoids Jackpotting when destroying a tree of objects." "[myToken < CurrentPacker fluidGet flockTable count ifTrue: [CurrentPacker fluidGet flockTable at: myToken store: NULL]] smalltalkOnly." CurrentPacker fluidGet destroyFlock: myInfo! ! !Abraham methodsFor: 'testing'! {UInt32 NOFAULT} actualHashForEqual ^myHash! {UInt32} contentsHash "A hash of the contents of this flock" ^self getCategory hashForEqual! {BooleanVar NOFAULT} isEqual: other {Heaper} ^self == other! {BooleanVar} isPurgeable "Return false only if the object cannot be flushed to disk. This will probably only be false for Stamps and the like that contain session level pointers." ^true! {BooleanVar NOFAULT} isShepherd "This should be replaced with an isKindOf: that first checks to see if you're asking about Abraham, and then otherwise possible faults." self hack. ^true! {BooleanVar NOFAULT} isStub "Distinguish between stubs and shepherds." ^false! {BooleanVar} isUnlocked "All manually generated subclasses are locked. Automatically defined unlocked classes will reimplement this." ^false! ! !Abraham methodsFor: 'accessing'! {FlockInfo NOFAULT} fetchInfo "Return the object that describes the state of this flock wrt disk." "This should be made protected." ^myInfo! {void NOFAULT} flockInfo: info {FlockInfo} "Set the object that knows where this flock is on disk. Change it when the object moves." | flocks {WeakPtrArray} | [info class == DeletedHeaper ifTrue: [self halt]] smalltalkOnly. myInfo _ info. (info token ~~ myToken and: [myToken ~~ nil]) ifTrue: [Abraham returnToken: myToken]. myToken _ myInfo token. "Register when a flockInfo has been assigned." flocks _ CurrentPacker fluidGet flockTable. myToken ~~ nil ifTrue: [myToken >= flocks count ifTrue: ["Grow if necessary." CurrentPacker fluidGet flockTable: ((flocks copyGrow: myToken) cast: WeakPtrArray). flocks destroy. flocks _ CurrentPacker fluidGet flockTable]] ifFalse: [[self halt] smalltalkOnly]. flocks at: myToken store: self. myInfo registerInfo! {FlockInfo NOFAULT} getInfo "Return the object that describes the state of this flock wrt disk." myInfo == NULL ifTrue: [Heaper BLAST: #MustBeInitialized]. [(myInfo class == DeletedHeaper) ifTrue: [self error: 'info was deleted']] smalltalkOnly. ^myInfo! {Category NOFAULT} getShepherdStubCategory "Return the category of stubs used for the receiver. Shepherd Patriarch classes reimplement this to use more specific Stub types." [^ShepherdStub] smalltalkOnly. ' BLAST(SHEPHERD_HAS_NO_STUB_DEFINED); return NULL;' translateOnly! {Int32 NOFAULT} token "Return the object that describes the state of this flock wrt disk." myToken == nil ifTrue: [[self halt] smalltalkOnly. myToken _ TheTokenSource takeToken ]. ^myToken! ! !Abraham methodsFor: 'protected: create'! create "New Shepherds must be stored to disk." super create. myHash _ CurrentPacker fluidGet nextHashForEqual. "Start out remembered, changing to forgotten. They also start out as if they were on disk (newShepherd must be called to make it so. This prevents intermediate diskUpdates from forcing a new object to disk before creation is finished." self restartAbraham! create.ShepFlag: ignored {ShepFlag var unused} with: hash {UInt32} with: info {FlockInfo} "This is the root of the automatically generated constructors for creating Stubs." super create. myHash _ hash. [info class == DeletedHeaper ifTrue: [self halt]] smalltalkOnly. self restartAbraham. info ~~ NULL ifTrue: [self flockInfo: info]! {INLINE} create: hash {UInt32} "This is for shepherds that are becoming from another shepherd." super create. self thingToDo. "Change my callers to use Abraham::Abraham(UInt32,APTR(FlockInfo)). The flockInfo should be restored at the Abraham level instead of below. This also more likely causes the type checker to catch inappropriate become-constructor use" myHash _ hash. self restartAbraham! ! !Abraham methodsFor: 'hooks:'! {void RECEIVE.HOOK} restartAbraham: trans {Rcvr unused default: NULL} myToken _ TheTokenSource takeToken. myToken == nil ifTrue: [self halt] smalltalkOnly. myInfo _ NULL.! ! !Abraham methodsFor: 'smalltalk: only'! create: hash {UInt32} with: info {FlockInfo} "This is for ShepherdStubs that use the hash and forgetFlag from the object for which they are stubbing." super create. myHash _ hash. [info class == DeletedHeaper ifTrue: [self halt]] smalltalkOnly. self flockInfo: info.! {BooleanVar} isKindOf: cat {Category} "Optimized for Abraham because xcvrs use it so much." ^cat == Abraham or: [super isKindOf: cat]! {void} restartAbraham self restartAbraham: NULL! ! !Abraham methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myHash _ receiver receiveUInt32. self restartAbraham: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendUInt32: myHash.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Abraham class instanceVariableNames: ''! (Abraham getOrMakeCxxClassDescription) friends: 'friend class SnarfPacker; friend class TestPacker; friend class FakePacker; friend class SnarfRecord; friend class SnarfHandler; friend void unlockFunctionAvoidingDestroy (Abraham *); friend class RecorderHoister; '; attributes: ((Set new) add: #DEFERRED.LOCKED; add: #DEFERRED; add: #COPY; yourself)! !Abraham class methodsFor: 'smalltalk: utilities'! dismantleStatistics ^DismantleStatistics! ! !Abraham class methodsFor: 'smalltalk: cleanup'! cleanupGarbage self linkTimeNonInherited! ! !Abraham class methodsFor: 'smalltalk: initialization'! initTimeNonInherited [DismantleStatistics _ IdentityDictionary new] smalltalkOnly. [self mayBecome: ShepherdStub] smalltalkOnly. TheTokenSource _ TokenSource make.! linkTimeNonInherited TheTokenSource _ NULL! staticTimeNonInherited BooleanVar defineFluid: #InsideTransactionFlag with: DiskManager emulsion with: [false].! ! !Abraham class methodsFor: 'global: functions'! {BooleanVar INLINE} isConstructed: obj {Heaper} ^obj ~~ NULL and: [obj getCategory ~~ DeletedHeaper]! {BooleanVar INLINE} isDestructed: obj {Heaper} ^obj == NULL or: [obj getCategory == DeletedHeaper]! ! !Abraham class methodsFor: 'tokens'! {Abraham} fetchShepherd: token {Int32} | table {PtrArray} | table := CurrentPacker fluidGet flockTable. token < table count ifTrue: [^(table fetch: token) cast: Abraham] ifFalse: [^NULL]! {void} returnToken: token {Int32} TheTokenSource returnToken: token! !Abraham subclass: #AgendaItem instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-turtle'! AgendaItem comment: 'A persistent representation of things that still need to be done. Can think of it like a persistent process record. "schedule"ing me ensures that I will be stepped eventually, and repeatedly, until step returns FALSE, even if the process should crash after I am scheduled. Scheduling me so that I am persistent may happen inside some other consistent block, however I will be stepped while outside of any consistent block (The FakePacker doesn''t do this yet). Creating an AgendaItem does not imply that it is scheduled, the client must explicitly schedule it as well. Destroying it *does* ensure that it gets unscheduled, though it is valid & safe to destroy one which isn''t scheduled. NOTE: Right now there are no fairness guarantees (and there may never be), so all AgendaItems must eventually terminate in order for other things (like the ServerLoop) to be guaranteed of eventually executing'! (AgendaItem getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #DEFERRED.LOCKED; yourself)! !AgendaItem methodsFor: 'accessing'! {void} forgetYourself "forget is protected. This method exposes it for AgendaItems" self forget! {void} rememberYourself "remember is protected. This method exposes it for AgendaItems" self remember! {void} schedule "Registers me with the top level Agenda, so that I will eventually get stepped. Also causes me to be remembered." [[self step] whileTrue] smalltalkOnly. "for debugging" CurrentPacker fluidGet getInitialFlock getAgenda registerItem: self! {BooleanVar} step "Return FALSE when there's nothing left to do (at which time I should usually be unregistered and destroyed, but see Agenda::step())" self thingToDo. "Change to return {AgendaItem (self or other) | NULL} and rename the message to fetchNextStep or the like. If we do this, we must remember that collapsing items must be just an optimization, because they can be stepped even after returning something else." self subclassResponsibility! {void} unschedule "Unregisters me with the top level Agenda, so that I am no longer scheduled to get stepped. Also causes me to be forgotten." CurrentPacker fluidGet getInitialFlock getAgenda unregisterItem: self! ! !AgendaItem methodsFor: 'protected: creation'! create "Not so special constructor for not becoming this class" super create! create: hash {UInt32} "Special constructor for becoming this class" super create: hash! {void} dismantle DiskManager consistent: 2 with: [self unschedule. super dismantle]! {void} newShepherd "All AgendaItems use explicit deletion semantics." "?????" super newShepherd.! ! !AgendaItem methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !AgendaItem subclass: #Agenda instanceVariableNames: 'myToDoList {MuSet of: AgendaItem}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-turtle'! Agenda comment: 'An AgendaItem composed of other AgendaItems. My stepping action consists of stepping one of my component items. When I exhaust a component item, I unregister and destroy it. Note: The order in which I select a component item is currently unspecified and uncontrolled (depending on "MuSet::stepper()"). Eventually, it may make sense for me to use the Escalator Algorithm to do prioritized scheduling. Empty Agendas are also made as do-nothing AgendaItems. The currently get duely get scheduled, stepped, and unscheduled. A possible optimization would be to avoid scheduling do-nothing AgendaItems.'! (Agenda getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !Agenda methodsFor: 'accessing'! {void} registerItem: item {AgendaItem} "By registering the item, we ensure that if we crash and reboot, the item will be eventually and repeatedly stepped until step returns FALSE, provided we are registered up through the Turtle. Do NOT multiply register the same item." DiskManager consistent: 2 with: [myToDoList introduce: item. "Why did we once have a 'bug?' annotation that this introduce needs to preceed the rememberYourself?" item rememberYourself. self diskUpdate]! {BooleanVar} step "'step' one of my component items. If I return FALSE, that means there's nothing currently left to do. However, since more AgendaItems may get registered later, there may later be something more for me to do, so I shouldn't necessarily be destroyed. This creates a composition problem: If an Agenda is stored as an item within another Agenda, then when the outer Agenda is stepped and it in turn steps the inner Agenda, if the inner Agenda returns FALSE, the outer Agenda will destroy it. This is all legal and shouldn't be a problem as long as one is aware of this behavior" | item {AgendaItem | NULL} stomp {Stepper} | "fetch some one item from myToDOList by creating a stepper, fetching with it, and destroying the stepper. If there were no items left return, telling the caller that there is nothing left to do. (We may do this repeatedly...) step the item. if it returned false unregister the item atomically destroy it (nuke it?) return whether there are any more things to do." item _ (stomp _ myToDoList stepper) fetch cast: AgendaItem. stomp destroy. self thingToDo. "The above code is n-squared. It should probably be fixed up during tuning." item == NULL ifTrue: [^false]. item step ifFalse: [self unregisterItem: item. DiskManager consistent: 2 with: [item destroy. self thingToDo. "find out if the consistent block is necessary/appropriate"]]. ^myToDoList isEmpty not! {void} unregisterItem: item {AgendaItem} "An item should be unregistered either when it is done (when 'step' returns FALSE) or when it no longer represents something that needs to be done should we crash and reboot. Unregistering an item which is not registered and already forgotten is legal and has no effect." DiskManager consistent: 2 with: [myToDoList wipe: item. item forgetYourself. self diskUpdate]! ! !Agenda methodsFor: 'creation'! create super create. myToDoList _ MuSet make. self knownBug. "A MuSet may become too big to fit within a snarf. However, GrandHashSets spawn AgendaItems and force propogating consistent block counts up through anything else that uses them." self newShepherd! {void} dismantle myToDoList stepper forEach: [:each {AgendaItem} | self unregisterItem: each. each destroy]. DiskManager consistent: 2 with: [myToDoList destroy. super dismantle]! ! !Agenda methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myToDoList _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myToDoList.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Agenda class instanceVariableNames: ''! (Agenda getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !Agenda class methodsFor: 'creation'! make self thingToDo. "see class comment for optimization possibility" DiskManager consistent: 1 with: [^self create]! !AgendaItem subclass: #GrandNodeDoubler instanceVariableNames: 'myNode {GrandNode | NULL}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-grantab'! GrandNodeDoubler comment: 'GrandNodeDoubler performs the page splitting required for the extensible GrandHashs in a deferred fashion.'! (GrandNodeDoubler getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !GrandNodeDoubler methodsFor: 'protected: creation'! create: gNode {GrandNode} super create. myNode _ gNode. self newShepherd.! ! !GrandNodeDoubler methodsFor: 'accessing'! {BooleanVar} step myNode ~~ NULL ifTrue: [DiskManager consistent: myNode doubleNodeConsistency + 2 with: [myNode doubleNode. myNode _ NULL. self diskUpdate]]. ^ false! ! !GrandNodeDoubler methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myNode _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myNode.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GrandNodeDoubler class instanceVariableNames: ''! (GrandNodeDoubler getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !GrandNodeDoubler class methodsFor: 'creation'! make: gNode {GrandNode} DiskManager consistent: 1 with: [ ^ GrandNodeDoubler create: gNode]! !AgendaItem subclass: #GrandNodeReinserter instanceVariableNames: ' myNode {GrandNode | NULL} myOverflow {GrandOverflow}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-grantab'! GrandNodeReinserter comment: 'GrandNodeReinserter moves the contents of the GrandOverflow structure into the newly doubled GrandNode.'! (GrandNodeReinserter getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !GrandNodeReinserter methodsFor: 'protected: creation'! create: gNode {GrandNode} with: gOverflow {GrandOverflow} super create. myNode _ gNode. myOverflow _ gOverflow. myNode addReinserter. self newShepherd.! ! !GrandNodeReinserter methodsFor: 'accessing'! {BooleanVar} step myNode ~~ NULL ifTrue: [DiskManager consistent: myOverflow reinsertEntriesConsistency + 2 with: [myOverflow reinsertEntries: myNode. myNode removeReinserter. myNode _ NULL. self diskUpdate]]. ^ false! ! !GrandNodeReinserter methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myNode _ receiver receiveHeaper. myOverflow _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myNode. xmtr sendHeaper: myOverflow.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GrandNodeReinserter class instanceVariableNames: ''! (GrandNodeReinserter getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !GrandNodeReinserter class methodsFor: 'creation'! make: gNode {GrandNode} with: gOverflow {GrandOverflow} DiskManager consistent: 2 with: [ ^ GrandNodeReinserter create: gNode with: gOverflow]! !AgendaItem subclass: #Matcher instanceVariableNames: ' myOrglRoot {OrglRoot | NULL} myFinder {PropFinder} myFossil {RecorderFossil}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-turtle'! Matcher comment: 'This is a one-shot agenda item. When doing a delayed backFollow, after the future is taken care of (by posting recorders in the Sensor Canopy), the past needs to be checked (by walking the HTree northwards filtered by the Bert Canopy). This AgendaItem is a one-shot used to remember to backFollow thru the past. (myOrglRoot == NULL when the shot has been done.)'! (Matcher getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !Matcher methodsFor: 'accessing'! {BooleanVar} step | | "If myStamp is NULL We've already shot once. Do nothing. walk the HTree northwards filtered by the Bert Canopy, scheduling RecorderTriggers to record already-existing matching stamps. ('past' part of backfollow) Remember that we're done." myOrglRoot == NULL ifTrue: [^false]. myFossil reanimate: [ :recorder {ResultRecorder} | myOrglRoot delayedFindMatching: myFinder with: myFossil with: recorder]. DiskManager consistent: 1 with: [myOrglRoot _ NULL. self thingToDo. "stop making sure the stamp sticks around" self diskUpdate. ^false]! ! !Matcher methodsFor: 'creation'! create: oroot {OrglRoot} with: finder {PropFinder} with: fossil {RecorderFossil} super create. myOrglRoot _ oroot. self thingToDo. "make sure the stamp sticks around. Do something like what's being done with myFossil>>addItem" myFinder _ finder. myFossil _ fossil. myFossil addItem: self. "bump refcount on myFossil" self newShepherd.! {void} dismantle DiskManager consistent: 3 with: [myFossil removeItem: self. "Unbump refcount on myFossil." self thingToDo. "stop making sure the OrglRoot sticks around. AgendaItems may be aborted by the enclosing algorithm, so can't assume I dropped my reference by stepping." super dismantle]! ! !Matcher methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myOrglRoot _ receiver receiveHeaper. myFinder _ receiver receiveHeaper. myFossil _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myOrglRoot. xmtr sendHeaper: myFinder. xmtr sendHeaper: myFossil.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Matcher class instanceVariableNames: ''! (Matcher getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !Matcher class methodsFor: 'creation'! make: oroot {OrglRoot} with: finder {PropFinder} with: fossil {RecorderFossil} DiskManager consistent: 2 with: [^self create: oroot with: finder with: fossil]! !AgendaItem subclass: #NorthRecorderChecker instanceVariableNames: ' myEdition {BeEdition} myFinder {PropFinder}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-turtle'! NorthRecorderChecker comment: 'This is a one-shot agenda item. See comment in SouthRecorderChecker for constraints and relationships to other pieces of the algorithm. Looks for and triggers WorkRecorders lying northward of this Edition up to the next Edition. The Finder should only be carrying around Works.'! (NorthRecorderChecker getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !NorthRecorderChecker methodsFor: 'accessing'! {BooleanVar} step Ravi knownBug. "if my WorkRecorders have been hoisted they will not be found; there needs to be a way to walk north in the sensor canopy until we pass an edition boundary" myEdition == NULL ifFalse: [Ravi thingToDo. "Make this work" "myEdition sensorCrum fetchNextAfterTriggeringRecorders: myFinder with: NULL." DiskManager consistent: 1 with: [myEdition := NULL. self thingToDo. "stop making sure the edition sticks around" self diskUpdate]]. ^false! ! !NorthRecorderChecker methodsFor: 'create'! create: edition {BeEdition} with: finder {PropFinder} super create. myEdition := edition. myFinder := finder. self newShepherd.! ! !NorthRecorderChecker methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myEdition _ receiver receiveHeaper. myFinder _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myEdition. xmtr sendHeaper: myFinder.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NorthRecorderChecker class instanceVariableNames: ''! (NorthRecorderChecker getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !NorthRecorderChecker class methodsFor: 'create'! {AgendaItem} make: edition {BeEdition} with: finder {PropFinder} ^self create: edition with: finder! !AgendaItem subclass: #PropChanger instanceVariableNames: 'myCrum {CanopyCrum | NULL}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-turtle'! PropChanger comment: 'Used to propagate some prop(erty) change rootwards in some canopy. Each step propagates it one step parentwards, until it gets to a local root or no further propagation in necessary.'! (PropChanger getOrMakeCxxClassDescription) attributes: ((Set new) add: #COPY; add: #DEFERRED; add: #SHEPHERD.PATRIARCH; add: #DEFERRED.LOCKED; yourself)! !PropChanger methodsFor: 'protected: accessing'! {CanopyCrum | NULL} fetchCrum ^myCrum! {void} setCrum: aCrum {CanopyCrum | NULL} "Move our placeholding finger to a new crum, updating refcounts accordingly" | | "atomically (though we've probably already gone nuclear) If there is a new crum bump its refcount. If there is an old crum unbump its refcount. Remember the new crum." DiskManager consistent: 3 with: [aCrum ~~ NULL ifTrue: [aCrum addPointer: self]. myCrum ~~ NULL ifTrue: [myCrum removePointer: self]. myCrum := aCrum. self diskUpdate].! ! !PropChanger methodsFor: 'accessing'! {BooleanVar} step "propagate some prop(erty) change one step parentwards, until it gets to a local root or no further propagation in necessary." self subclassResponsibility! ! !PropChanger methodsFor: 'creation'! create: crum {CanopyCrum | NULL} super create. myCrum _ crum. myCrum == NULL ifTrue: [myCrum addPointer: self].! create: crum {CanopyCrum | NULL} with: hash {UInt32} "Special constructor for becoming this class" super create: hash. myCrum _ crum. "I don't 'myCrum addPointer: self' because, in becoming, my old self is presumed to already have pointed at the crum"! {void} dismantle DiskManager consistent: 2 with: [myCrum ~~ NULL ifTrue: [myCrum removePointer: self. myCrum _ NULL]. super dismantle]! ! !PropChanger methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myCrum _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myCrum.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PropChanger class instanceVariableNames: ''! (PropChanger getOrMakeCxxClassDescription) attributes: ((Set new) add: #COPY; add: #DEFERRED; add: #SHEPHERD.PATRIARCH; add: #DEFERRED.LOCKED; yourself)! !PropChanger class methodsFor: 'creation'! {PropChanger} height: crum {CanopyCrum | NULL} DiskManager consistent: 3 with: [^HeightChanger create: crum]! make: crum {CanopyCrum | NULL} DiskManager consistent: 2 with: [^ActualPropChanger create: crum]! ! !PropChanger class methodsFor: 'smalltalk: suspended'! make: crum {CanopyCrum | NULL} with: change {PropChange} self suspended. self thingToDo. " Separate out different things to be propagatated into different PropChanger-like classes." DiskManager consistent: 3 with: [^ActualPropChanger create: crum with: change]! !PropChanger subclass: #ActualPropChanger instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-turtle'! ActualPropChanger comment: 'Used to propagate some prop(erty) change rootwards in some canopy. Each step propagates it one step parentwards, until it gets to a local root or no further propagation in necessary.'! (ActualPropChanger getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #LOCKED; add: #COPY; yourself)! !ActualPropChanger methodsFor: 'creation'! create: crum {CanopyCrum} super create: crum. self newShepherd.! create: crum {CanopyCrum | NULL} with: hash {UInt32} with: info {FlockInfo} "Special constructor for becoming this class" super create: crum with: hash. self flockInfo: info. self diskUpdate.! ! !ActualPropChanger methodsFor: 'accessing'! {BooleanVar} step | | "If I'm done Stop me before I step again!!. atomically Do one step of property changing. If more needs to be done, step rootward. (myCrum is set to NULL if I am the root.) else I'm done. Remember it by setting myCrum to NULL return a flag saying whether I'm done" self fetchCrum == NULL ifTrue: [^false]. DiskManager consistent: 3 with: [(self fetchCrum changeCanopy) ifTrue: [self setCrum: self fetchCrum fetchParent] ifFalse: [self setCrum: NULL]]. ^self fetchCrum ~~ NULL! ! !ActualPropChanger methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !PropChanger subclass: #HeightChanger instanceVariableNames: 'myChange {PropChange}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-turtle'! HeightChanger comment: 'Used to propagate some prop(erty) change rootwards in some canopy. Each step propagates it one step parentwards, until it gets to a local root or no further propagation in necessary.'! (HeightChanger getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #LOCKED; add: #COPY; yourself)! !HeightChanger methodsFor: 'creation'! create: crum {CanopyCrum} super create: crum. self newShepherd.! create: crum {CanopyCrum | NULL} with: hash {UInt32} with: info {FlockInfo} "Special constructor for becoming this class" super create: crum with: hash. self flockInfo: info. self diskUpdate.! ! !HeightChanger methodsFor: 'accessing'! {BooleanVar} step | | "If I'm done Stop me before I step again!!. atomically Do one step of height recalculation. If more needs to be done, step rootward. (myCrum is set to NULL if I am the root.) else I'm done. Remember it by setting myCrum to NULL return a flag saying whether I'm done" self fetchCrum == NULL ifTrue: [^false]. DiskManager consistent: 3 with: [self fetchCrum changeHeight ifTrue: [self setCrum: self fetchCrum fetchParent] ifFalse: [self setCrum: NULL]]. ^self fetchCrum ~~ NULL! ! !HeightChanger methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myChange _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myChange.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HeightChanger class instanceVariableNames: ''! (HeightChanger getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #LOCKED; add: #COPY; yourself)! !HeightChanger class methodsFor: 'creation'! make: crum {CanopyCrum} with: change {PropChange unused} self knownBug. "BOGUS" DiskManager consistent: 3 with: [^self create: crum]! !PropChanger subclass: #RecorderHoister instanceVariableNames: 'myCargo {MuSet of: TransclusionFossil}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-turtle'! RecorderHoister comment: ' NOT.A.TYPE I exist to hoist myCargo (a set of recorder fossils) up the Sensor canopy as far as it needs to go, as well as to propogate the props resulting from the planting of these recorders. When I no longer have any cargo to hoist, I devolve into an ActualPropChanger I assume that RecorderCheckers do their southward walk in a single step, so I can hoist recorders by an algorithm that would occasionally cause a recorder to be missed if RecorderCheckers were incremental.'! (RecorderHoister getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #(MAY.BECOME ActualPropChanger ); add: #CONCRETE; yourself)! !RecorderHoister methodsFor: 'creation'! create: crum {CanopyCrum} with: aSetOfRecorders {MuSet of: RecorderFossil} super create: crum. myCargo _ aSetOfRecorders. self newShepherd.! ! !RecorderHoister methodsFor: 'accessing'! {BooleanVar} step | | "See class comment for a constraint I impose on another class. If I'm done Stop me before I step again!!. atomically Do one step of property changing (and/or height recalculation until that's moved to HeightChanger). If more needs to be done, step rootward. (myCrum is set to NULL if I am the root.) else I'm done. Remember it by setting myCrum to NULL return a flag saying whether I'm done" self thingToDo. "update comment after we move height calculation to HeightChanger>>step" self fetchCrum == NULL ifTrue: [^false]. DiskManager consistent: 3 with: [ | crum {CanopyCrum | NULL} propsChangedFlag {BooleanVar} | crum := self fetchCrum fetchParent. propsChangedFlag := self fetchCrum changeCanopy. "All the updating of myPropJoint that's needed even though I hoist recorders into my parent below, since hoisting cannot change what myPropJoint needs to be." self setCrum: crum. crum == NULL ifTrue: [^false]. myCargo restrictTo: (crum fetchChild1 cast: SensorCrum) recorders; restrictTo: (crum fetchChild2 cast: SensorCrum) recorders. self diskUpdate. myCargo isEmpty ifTrue: [| hash {UInt32} info {FlockInfo} | propsChangedFlag ifFalse: [self setCrum: NULL. ^false]. myCargo destroy. "Normally done by destruct, but here we do it directly because we're about to become something" hash _ self hashForEqual. info _ self fetchInfo. (ActualPropChanger new.Become: self) create: crum with: hash with: info. "the special purpose constructor will not do a 'crum->addPointer(this)' so we don't have to undo it" ^true]. "If we reach this point, we have cargo to hoist." (crum fetchChild1 cast: SensorCrum) removeRecorders: myCargo asImmuSet. (crum fetchChild2 cast: SensorCrum) removeRecorders: myCargo asImmuSet. myCargo wipeAll: (crum cast: SensorCrum) recorders. myCargo isEmpty ifTrue: [propsChangedFlag ifFalse: [self setCrum: NULL]. ^propsChangedFlag] ifFalse: [(crum cast: SensorCrum) installRecorders: myCargo asImmuSet. crum diskUpdate]]. ^true! ! !RecorderHoister methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myCargo _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myCargo.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RecorderHoister class instanceVariableNames: ''! (RecorderHoister getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #(MAY.BECOME ActualPropChanger ); add: #CONCRETE; yourself)! !RecorderHoister class methodsFor: 'creation'! {AgendaItem} make: crum {CanopyCrum} with: aSetOfRecorders {ScruSet of: RecorderFossil} "Create a RecorderHoister." aSetOfRecorders isEmpty ifTrue: [^Agenda make]. DiskManager consistent: 1 with: [^self create: crum with: aSetOfRecorders asMuSet]! !AgendaItem subclass: #RecorderTrigger instanceVariableNames: ' myFossil {RecorderFossil | NULL} myElement {BeRangeElement}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-turtle'! RecorderTrigger comment: 'This is a one-shot agenda item. Asks myFossil to record myElement. When an answer to a delayed backFollow is found, whether thru a northwards h-walk (filtered by the Bert Canopy) of a southwards o-walk (filtered by the Sensor Canopy), instead of actually recording the answer into the backFollow trail immediately, we shedule a RecorderTrigger to do the job.'! (RecorderTrigger getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !RecorderTrigger methodsFor: 'accessing'! {BooleanVar} step || "If null pointer to myFossil We've already shot once. Do nothing. If myFossil is still in suspension Inform myFossil with myElement Atomically Remove refcount from ourself on myFossil. Remember that we're done." myFossil == NULL ifTrue: [^false]. myFossil isExtinct ifFalse: [myFossil reanimate: [:recorder {ResultRecorder} | recorder record: myElement]]. DiskManager consistent: 2 with: [myFossil removeItem: self. myFossil _ NULL. self thingToDo. "stop making sure the Edition doesn't go away; it needs a refcount or something like it." self diskUpdate. ^false].! ! !RecorderTrigger methodsFor: 'creation'! create: fossil {RecorderFossil} with: element {BeRangeElement} super create. myFossil _ fossil. myFossil addItem: self. myElement _ element. self thingToDo. "make sure the RangeElement doesn't go away" self newShepherd.! {void} dismantle DiskManager consistent: 2 with: [myFossil ~~ NULL ifTrue: [myFossil removeItem: self. myFossil _ NULL]. self thingToDo. "stop making sure the stamp doesn't go away" super dismantle]! ! !RecorderTrigger methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myFossil _ receiver receiveHeaper. myElement _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myFossil. xmtr sendHeaper: myElement.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RecorderTrigger class instanceVariableNames: ''! (RecorderTrigger getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !RecorderTrigger class methodsFor: 'creation'! make: fossil {RecorderFossil} with: element {BeRangeElement} DiskManager consistent: 2 with: [^self create: fossil with: element]! !AgendaItem subclass: #Sequencer instanceVariableNames: ' myFirst {AgendaItem | NULL} myRest {AgendaItem}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-turtle'! Sequencer comment: 'An AgendaItem composed of two other AgendaItems. Used for when all of the first needs to be done before any of the second may be done. My stepping action consists of stepping myFirst. When it is exhausted, I destroy it and then start stepping myRest'! (Sequencer getOrMakeCxxClassDescription) attributes: ((Set new) add: #SHEPHERD.PATRIARCH; add: #COPY; add: #LOCKED; add: #NOT.A.TYPE; add: #CONCRETE; yourself)! !Sequencer methodsFor: 'protected: creation'! create: first {AgendaItem} with: rest {AgendaItem} super create. myFirst _ first. myRest _ rest. first rememberYourself. rest rememberYourself. self newShepherd.! ! !Sequencer methodsFor: 'accessing'! {BooleanVar} step myFirst == NULL ifTrue: [^myRest step] ifFalse: [myFirst step ifFalse: [DiskManager consistent: 2 with: [myFirst destroy. myFirst _ NULL. self diskUpdate]]. ^true]! ! !Sequencer methodsFor: 'creation'! {void} dismantle DiskManager consistent: 3 with: [myFirst ~~ NULL ifTrue: [myFirst destroy]. myRest destroy. super dismantle]! ! !Sequencer methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myFirst _ receiver receiveHeaper. myRest _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myFirst. xmtr sendHeaper: myRest.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Sequencer class instanceVariableNames: ''! (Sequencer getOrMakeCxxClassDescription) attributes: ((Set new) add: #SHEPHERD.PATRIARCH; add: #COPY; add: #LOCKED; add: #NOT.A.TYPE; add: #CONCRETE; yourself)! !Sequencer class methodsFor: 'creation'! {AgendaItem} make: first {AgendaItem} with: rest {AgendaItem} DiskManager consistent: 3 with: [^self create: first with: rest]! !AgendaItem subclass: #SouthRecorderChecker instanceVariableNames: ' myORoot {OrglRoot | NULL} myFinder {PropFinder} mySCrum {SensorCrum | NULL}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-turtle'! SouthRecorderChecker comment: 'This is a one-shot agenda item. When changing the prop(ertie)s of a Stamp, we need to first take care of the future backFollow requests (by updating the Bert Canopy so the filtered HTree walk will find this Stamp) before taking care of the past (the Recorders that were looking for this Stamp in their future). This AgendaItem is to remember to take care of the past (by doing a southwards o-walk filtered by the Sensor Canopy) after the future is properly dealt with. The RecorderHoister assumes that this southward walk is done in a single-step, so it is free to make changes in a way that, if it were interleaved with an incremental southward walk by a RecorderChecker looking for the recorder(s) being hoisted, might cause the hoisted recorder to be missed. This is also used recursively by this very o-walk to schedule a further o-walk on appropriate sub-Stamps. Keeping track of whether persistent objects are garbage-on-disk during AgendaItem processing only remains open for Stamps, except here where it also arises for an OrglRoot. The OrglRoot is itself held by a persistent Stamp, from which it can be easily obtained, so we should probably just hold onto two Stamps instead of a Stamp and an OrglRoot (so I only have to solve the "how to keep it around" problem for Stamps).'! (SouthRecorderChecker getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !SouthRecorderChecker methodsFor: 'creation'! create: oroot {OrglRoot} with: finder {PropFinder} with: scrum {SensorCrum | NULL} super create. myORoot _ oroot. myFinder _ finder. self knownBug. "make sure these objects stick around. mySCrum has add/removePointer already. myStamp and myORoot need something similar. myFinder is one of my sheep and is already OK." mySCrum _ scrum. mySCrum ~~ NULL ifTrue: [mySCrum addPointer: self]. self newShepherd.! {void} dismantle DiskManager consistent: 3 with: [mySCrum ~~ NULL ifTrue: [mySCrum removePointer: self. mySCrum _ NULL]. self thingToDo. "stop making sure these objects stick around" super dismantle]! ! !SouthRecorderChecker methodsFor: 'accessing'! {BooleanVar} step | | "See class comment for a constraint on this method. If empty ORoot We've already shot once. Do nothing. Check for any recorders in the sensor canopy that need to be rung. Remember that we're done." myORoot == NULL ifTrue: [^false]. myORoot checkRecorders: myFinder with: mySCrum. DiskManager consistent: 1 with: [myORoot _ NULL. self thingToDo. "stop making sure these objects stick around" self diskUpdate. ^false]! ! !SouthRecorderChecker methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myORoot _ receiver receiveHeaper. myFinder _ receiver receiveHeaper. mySCrum _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myORoot. xmtr sendHeaper: myFinder. xmtr sendHeaper: mySCrum.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! SouthRecorderChecker class instanceVariableNames: ''! (SouthRecorderChecker getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !SouthRecorderChecker class methodsFor: 'creation'! make: oroot {OrglRoot} with: finder {PropFinder} with: scrum {SensorCrum | NULL} DiskManager consistent: 2 with: [^self create: oroot with: finder with: scrum]! ! !SouthRecorderChecker class methodsFor: 'smalltalk: passe'! make: oroot {OrglRoot} with: stamp {BeEdition} with: finder {PropFinder} with: scrum {SensorCrum | NULL} self passe "fewer args"! !AgendaItem subclass: #UpdateTransitiveMemberIDs instanceVariableNames: 'myClubs {MuSet of: BeClub}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-brange2'! UpdateTransitiveMemberIDs comment: 'This carries on the updating of transitive member IDs for the given club.'! (UpdateTransitiveMemberIDs getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !UpdateTransitiveMemberIDs methodsFor: 'accessing'! {BooleanVar} step myClubs isEmpty ifFalse: [DiskManager consistent: 5 with: [| club {BeClub} stomp {Stepper} | club := (stomp := myClubs stepper) fetch cast: BeClub. stomp destroy. club updateTransitiveMemberIDs. myClubs remove: club. self diskUpdate]]. ^ myClubs isEmpty not! ! !UpdateTransitiveMemberIDs methodsFor: 'protected: creation'! create: clubs {MuSet of: BeClub} super create. myClubs := clubs. self newShepherd.! ! !UpdateTransitiveMemberIDs methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myClubs _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myClubs.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! UpdateTransitiveMemberIDs class instanceVariableNames: ''! (UpdateTransitiveMemberIDs getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !UpdateTransitiveMemberIDs class methodsFor: 'creation'! make: clubs {MuSet of: BeClub} ^ self create: clubs! !AgendaItem subclass: #UpdateTransitiveSuperClubIDs instanceVariableNames: ' myClubs {MuSet of: BeClub | NULL} myGrandMap {BeGrandMap}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-brange2'! UpdateTransitiveSuperClubIDs comment: 'This carries on the updating of transitive superclass IDs for the given club.'! (UpdateTransitiveSuperClubIDs getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !UpdateTransitiveSuperClubIDs methodsFor: 'accessing'! {BooleanVar} step myClubs isEmpty ifFalse: [DiskManager consistent: 2 with: [| club {BeClub} stomp {Stepper} | club := (stomp := myClubs stepper) fetch cast: BeClub. stomp destroy. CurrentGrandMap fluidBind: myGrandMap during: [club updateTransitiveSuperClubIDs]. myClubs remove: club. self diskUpdate]]. ^ myClubs isEmpty not! ! !UpdateTransitiveSuperClubIDs methodsFor: 'protected: creation'! create: clubs {MuSet of: BeClub} with: grandMap {BeGrandMap} super create. myClubs := clubs. myGrandMap := grandMap. self newShepherd.! ! !UpdateTransitiveSuperClubIDs methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myClubs _ receiver receiveHeaper. myGrandMap _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myClubs. xmtr sendHeaper: myGrandMap.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! UpdateTransitiveSuperClubIDs class instanceVariableNames: ''! (UpdateTransitiveSuperClubIDs getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !UpdateTransitiveSuperClubIDs class methodsFor: 'creation'! make: clubs {MuSet of: BeClub} with: grandMap {BeGrandMap} ^ self create: clubs with: grandMap! !Abraham subclass: #BeGrandMap instanceVariableNames: ' myIdentifier {Sequence} myGlobalIDSpace {IDSpace} myLocalIDSpaceCounter {Counter} myGlobalIDFilterSpace {FilterSpace of: IDSpace} myEndorsementSpace {CrossSpace} myEndorsementFilterSpace {FilterSpace of: CrossSpace} myIDHolders {MuTable of: ID with: IDHolder} myIDCounters {MuTable of: (Tuple of: Sequence with: IntegerPos) with: Counter} myRangeElements {MuTable of: ID with: BeRangeElement} myRangeElementIDs {MuTable of: (HeaperAsPosition of: BeRangeElement) with: IDRegion | ID} myEnt {Ent} myEmptyClubID {ID} myPublicClubID {ID} myAdminClubID {ID} myArchiveClubID {ID} myAccessClubID {ID} myClubDirectoryID {ID} myGateLockSmithEdition {BeEdition} myWrapperEndorsements {ImmuTable of: Sequence with: CrossRegion} myEndorsementFlags {PtrArray of: Tuple | CrossRegion} myPurgeable {BooleanVar NOCOPY} myGrants {BeEdition of: Club} myAcceptingConnectionsFlag {BooleanVar NOCOPY}' classVariableNames: 'BackendCount {IntegerVar smalltalk} ' poolDictionaries: '' category: 'Xanadu-Be-Basic'! BeGrandMap comment: 'Rewrite notes 3/7/92 ravi - we had decided to have myRangeElementIDs be a GrandSetTable, but for now its just a Table onto IDRegions, since that is what we have implemented right now'! (BeGrandMap getOrMakeCxxClassDescription) friends: 'friend class BackendBootMaker; '; attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !BeGrandMap methodsFor: 'private: booting'! {void} clubConsistencyCheck "Check that the BeClub structure matches the Editions underneath them" Ravi thingToDo! {void} coldBoot | emptyDesc {FeEdition} emptyClub {BeClub} publicDesc {FeEdition} publicClub {BeClub} adminClub {BeClub} archiveClub {BeClub} clubNames {BeEdition} endorsements {MuTable of: Sequence and: CrossRegion} number {IntegerVar} iDSpace {IDSpace} endorseTokenWorks {BeEdition} | "set up the initial set of Clubs" myEmptyClubID := ID make: NULL with: NULL with: -1. myPublicClubID := ID make: NULL with: NULL with: -2. self thingToDo. "ensure that the following IDs are deterministic" myAdminClubID := myGlobalIDSpace newID. myArchiveClubID := myGlobalIDSpace newID. myAccessClubID := myGlobalIDSpace newID. "figure out the IDs of the Wrapper endorsement Works" endorsements := MuTable make: SequenceSpace make. number := -3. FeWrapperSpec knownWrappers stepper forEach: [ :name {Sequence} | | iD {ID} | Ravi thingToDo. "put something more descriptive here" iD := ID make: NULL with: NULL with: number. number := number - 1. endorsements at: name introduce: (myEndorsementSpace crossOfRegions: ((PrimSpec pointer arrayWithTwo: myArchiveClubID asRegion with: iD asRegion) cast: PtrArray))]. myWrapperEndorsements := endorsements asImmuTable. "set up the special flag bits used by the canopy" myEndorsementFlags := PtrArray nulls: 5+10. myEndorsementFlags at: UInt32Zero store: ((endorsements get: (Sequence string: 'Text')) cast: XnRegion) theOne. myEndorsementFlags at: 1 store: ((endorsements get: (Sequence string: 'HyperLink')) cast: XnRegion) theOne. myEndorsementFlags at: 2 store: ((endorsements get: (Sequence string: 'HyperRef')) cast: XnRegion) theOne. myEndorsementFlags at: 3 store: ((endorsements get: (Sequence string: 'SingleRef')) cast: XnRegion) theOne. myEndorsementFlags at: 4 store: ((endorsements get: (Sequence string: 'MultiRef')) cast: XnRegion) theOne. "generate some IDs to use as endorsement tokens" 5 almostTo: myEndorsementFlags count do: [ :i {Int32} | myEndorsementFlags at: i store: (myEndorsementSpace crossOfRegions: ((PrimSpec pointer arrayWithTwo: myGlobalIDSpace fullRegion with: myGlobalIDSpace newID asRegion) cast: PtrArray))]. CanopyCrum useEndorsementFlags: myEndorsementFlags. CurrentAuthor fluidSet: myEmptyClubID. InitialReadClub fluidSet: myPublicClubID. InitialEditClub fluidSet: myEmptyClubID. InitialOwner fluidSet: myEmptyClubID. InitialSponsor fluidSet: myEmptyClubID. Dean knownBug. "Who sponsors clubs?" emptyDesc := (self carrier: (self newEmptyEdition: SequenceSpace make)) makeFe cast: FeEdition. emptyClub := self newClub: emptyDesc with: myEmptyClubID. emptyClub setEditClub: NULL. publicDesc := (self carrier: (self newEditionWith: (Sequence string: 'ClubDescription:LockSmith') with: (self carrier: (self newDataEdition: (UInt8Array string: 'boo') with: (IntegerRegion make: IntegerVarZero with: 3) with: IntegerSpace make getAscending)))) makeFe cast: FeEdition. publicClub := self newClub: publicDesc with: myPublicClubID. publicClub setEditClub: NULL. emptyClub sponsor: (myPublicClubID asRegion cast: IDRegion). publicClub sponsor: (myPublicClubID asRegion cast: IDRegion). InitialSponsor fluidSet: myPublicClubID. InitialReadClub fluidSet: myAdminClubID. InitialEditClub fluidSet: myAdminClubID. InitialOwner fluidSet: myAdminClubID. self thingToDo. "This should probably still be the Null Club." adminClub := self newClub: publicDesc with: myAdminClubID. InitialReadClub fluidSet: myArchiveClubID. InitialEditClub fluidSet: myArchiveClubID. InitialOwner fluidSet: myArchiveClubID. archiveClub := self newClub: publicDesc with: myArchiveClubID. CurrentKeyMaster fluidSet: (FeKeyMaster make: self publicClubID). InitialReadClub fluidSet: myAdminClubID. InitialEditClub fluidSet: myAdminClubID. iDSpace := IDSpace unique. self newClub: ((self carrier: (self newEditionWith: (Sequence string: 'ClubDescription:Membership') with: (self carrier: (((self newEditionWith: iDSpace newID with: (self carrier: publicClub)) with: iDSpace newID with: (self carrier: adminClub)) with: iDSpace newID with: (self carrier: archiveClub))))) makeFe cast: FeEdition) with: myAccessClubID. InitialReadClub fluidSet: myPublicClubID. InitialSponsor fluidSet: myAdminClubID. InitialEditClub fluidSet: myAdminClubID. clubNames := (((self newEditionWith: (Sequence string: 'System Admin') with: (self carrier: adminClub)) combine: (self newEditionWith: (Sequence string: 'System Archive') with: (self carrier: archiveClub))) combine: (self newEditionWith: (Sequence string: 'Universal Null') with: (self carrier: emptyClub))) combine: (self newEditionWith: (Sequence string: 'Universal Public') with: (self carrier: publicClub)). myClubDirectoryID := self assignID: (self newWork: (FeEdition on: clubNames)). "actually create the Wrapper description Works" endorsements stepper forPositions: [ :name {Sequence} :end {CrossRegion} | Ravi thingToDo. "put something more descriptive in the Work" self at: (((end theOne cast: Tuple) coordinate: 1) cast: ID) tryIntroduce: (self newWork: (FeEdition on: (self newDataEdition: name integers with: (IntegerRegion make: IntegerVarZero with: name integers count) with: IntegerSpace make ascending)))]. "actually create the endorsement token Works" iDSpace := IDSpace unique. endorseTokenWorks := self newEmptyEdition: iDSpace. 5 almostTo: myEndorsementFlags count do: [ :i {Int32} | | work {BeWork} | work := self newWork: emptyDesc. "contents don't matter" self at: (((((myEndorsementFlags get: i) cast: CrossRegion) projection: 1) cast: IDRegion) theOne cast: ID) tryIntroduce: work. endorseTokenWorks := endorseTokenWorks with: iDSpace newID with: (self carrier: work)]. "attach & endorse them so they can be found" InitialReadClub fluidBind: myAdminClubID during: [InitialEditClub fluidBind: NULL during: [ | edition {BeEdition} | edition := (self newEditionWith: (Sequence string: 'Universal Public') with: (self carrier: publicClub)) with: (Sequence string: 'Fast Tokens') with: (self carrier: endorseTokenWorks). self newWork: (FeEdition on: edition). edition endorse: (myEndorsementSpace crossOfRegions: ((PrimSpec pointer arrayWithTwo: myEmptyClubID asRegion with: myEmptyClubID asRegion) cast: PtrArray))]]. myGateLockSmithEdition := self newDataEdition: (UInt8Array string: 'wall') with: (IntegerRegion make: IntegerVarZero with: 4) with: IntegerSpace make ascending. myGrants := self newEditionWithAll: myGlobalIDSpace fullRegion with: (self carrier: adminClub). InitialOwner fluidSet: (NULL basicCast: ID). InitialSponsor fluidSet: (NULL basicCast: ID). InitialReadClub fluidSet: myEmptyClubID. InitialEditClub fluidSet: (NULL basicCast: ID). CurrentAuthor fluidSet: (NULL basicCast: ID). CurrentKeyMaster fluidSet: (NULL basicCast: FeKeyMaster).! ! !BeGrandMap methodsFor: 'private: create'! create: identifier {Sequence} super create. DiskManager consistent: [ | counter {Counter} | self newShepherd. "newShepherd must be first in GrandMap so that it is the boot object." myPurgeable := false. "The GrandMap cannot be purged until it is explicitly allowed." myEnt := Ent make. myIdentifier := identifier. "The counters table must be setup before we try to make any IDSpaces" myIDCounters := MuTable make: (CrossSpace make: SequenceSpace make with: IntegerSpace make). counter := Counter make: 1 with: 20. myGlobalIDSpace := IDSpace make: NULL with: -1 with: counter. myIDCounters at: (Tuple two: Sequence zero with: -1 integer) introduce: counter. myLocalIDSpaceCounter := Counter make: 1 with: 256. myGlobalIDFilterSpace := FilterSpace make: (myGlobalIDSpace cast: CoordinateSpace). myEndorsementSpace := CrossSpace make: ((PrimSpec pointer arrayWithTwo: myGlobalIDSpace with: myGlobalIDSpace) cast: PtrArray). myEndorsementFilterSpace := FilterSpace make: (myEndorsementSpace cast: CoordinateSpace). myRangeElements := GrandHashTable make: myGlobalIDSpace. myIDHolders := GrandHashTable make: myGlobalIDSpace. myRangeElementIDs := GrandHashTable make: HeaperSpace make. self hack. "how does this connect" CurrentGrandMap fluidBind: self during: [self coldBoot]. self remember]. CurrentGrandMap fluidBind: self during: [self clubConsistencyCheck]. myPurgeable _ false. myAcceptingConnectionsFlag _ true.! ! !BeGrandMap methodsFor: 'hooks:'! {void RECEIVE.HOOK} restartBeGrandMap: rcvr {Rcvr unused} myPurgeable _ false. myAcceptingConnectionsFlag _ true. CanopyCrum useEndorsementFlags: myEndorsementFlags! ! !BeGrandMap methodsFor: 'purging'! {void} bePurgeable "Allow the GrandMap to be purged. The GrandMap should NOT be used after this is called." myPurgeable := true.! {BooleanVar} isPurgeable "The Grandmap never gets purged unless explicitly allowed by calling bePurgeable." ^ myPurgeable! ! !BeGrandMap methodsFor: 'testing'! {UInt32} contentsHash ^(((((super contentsHash bitXor: myIdentifier hashForEqual) bitXor: myLocalIDSpaceCounter hashForEqual) bitXor: myEnt hashForEqual) bitXor: myEmptyClubID hashForEqual) bitXor: myPublicClubID hashForEqual) bitXor: myAdminClubID hashForEqual! ! !BeGrandMap methodsFor: 'accessing'! {void} acceptConnections: open {BooleanVar} "See FeAdminer" myAcceptingConnectionsFlag := open! {ID} assignID: value {BeRangeElement} "Remember the two way association between value and its new ID." | iD {ID} | Ravi knownBug. "what if the ID has already been assigned by the grantee?" iD _ self newID. (self at: iD tryIntroduce: value) ifFalse: [Heaper BLAST: #IDAlreadyUsed]. ^iD! {BooleanVar} at: iD {ID} tryIntroduce: value {BeRangeElement} "Remember the two way association between value and the supplied ID." (myRangeElements includesKey: iD) ifTrue: [^false]. self hack. "The number below comes frojm my memory of how big a GrandMap assign can be." DiskManager consistent: 6 with: [| hap {HeaperAsPosition} already {IDRegion | NULL} | self thingToDo. "Decide about multiple IDs" hap := HeaperAsPosition make: value. already := (myRangeElementIDs fetch: hap) cast: IDRegion. already == NULL ifTrue: [myRangeElementIDs at: hap introduce: iD asRegion] ifFalse: [(value isKindOf: BeClub) ifTrue: [Heaper BLAST: #ClubMustHaveUniqueID]. myRangeElementIDs at: hap replace: (already with: iD)]. myRangeElements at: iD introduce: value]. ^true! {ID} clubDirectoryID ^myClubDirectoryID! {FilterSpace} endorsementFilterSpace ^myEndorsementFilterSpace! {CrossSpace} endorsementSpace ^myEndorsementSpace! {BeRangeElement | NULL} fetch: iD {ID} "The actual BeRangeElement at that ID, or NULL if there is none" ^(myRangeElements fetch: iD) cast: BeRangeElement! {BeClub | NULL} fetchClub: iD {ID | NULL} "If there is a club at the given ID, return it." iD == NULL ifTrue: [^NULL]. (self get: iD) cast: BeClub into: [:club | ^club] others: []. ^NULL! {FeEdition} gateLockSmithEdition ^FeEdition on: (myGateLockSmithEdition)! {BeRangeElement} get: iD {ID} "The actual BeRangeElement at that ID, or blast if there is none" ^(myRangeElements get: iD) cast: BeRangeElement! {BeClub} getClub: iD {ID} "Get a BeClub from the GrandMap." ^(self get: iD) cast: BeClub! {FeRangeElement} getFe: iD {ID} "Get what is at the the given ID as a front end object; blast if there is nothing there" self knownBug. "This doesn't supply a label for Editions." ^(self get: iD) makeFe: NULL! {Counter} getOrMakeIDCounter: backend {Sequence | NULL} with: number {IntegerVar} "Get a canonical Counter for an IDSpace, or make a new one" | result {Counter} theBackend {Sequence} | backend ~~ NULL ifTrue: [theBackend := backend] ifFalse: [number < IntegerVarZero ifTrue: [theBackend := Sequence zero] ifFalse: [theBackend := self identifier]]. result := (myIDCounters fetch: (Tuple two: theBackend with: number integer)) cast: Counter. result == NULL ifTrue: [self thingToDo. "figure out good batching" result := Counter make: 1 with: 20. myIDCounters at: (Tuple two: theBackend with: number integer) introduce: result]. ^result! {BeIDHolder} getOrMakeIDHolder: iD {ID} "If there is already an IDHolder for the ID then return it, otherwise make one" | result {BeIDHolder} | result := (myIDHolders fetch: iD) cast: BeIDHolder. result == NULL ifTrue: ["Make one and remember it for canonicalization" CurrentPacker fluidGet consistent: 666 with: [result := BeIDHolder make: iD. myIDHolders at: iD introduce: result]]. ^result! {FilterSpace} globalIDFilterSpace "The FilterSpace on global IDSpace" ^myGlobalIDFilterSpace! {IDSpace} globalIDSpace "The global IDSpace" ^myGlobalIDSpace! {void} grant: clubID {ID} with: globalIDs {IDRegion} "See FeAdminer" | newGrants {BeEdition} | newGrants := myGrants replace: (self newEditionWithAll: globalIDs with: (self carrier: (self getClub: clubID))). DiskManager consistent: 1 with: [myGrants := newGrants. self diskUpdate]! {ID} grantAt: iD {ID} "Who has been granted authority to assign that ID" ^self iDOf: (myGrants get: iD) getOrMakeBe! {TableStepper of: ID and: IDRegion} grants: clubIDs {IDRegion | NULL} with: globalIDs {IDRegion | NULL} "See FeAdminer" | theEdition {BeEdition} | globalIDs == NULL ifTrue: [theEdition := myGrants] ifFalse: [theEdition := myGrants copy: globalIDs]. ^GrantStepper make: theEdition with: clubIDs! {Sequence} identifier ^myIdentifier! {ID} iDOf: value {BeRangeElement} "Find the ID of a BeRangeElement. Blast if there is no ID or if there is more than one" | result {IDRegion | NULL} | result := (myRangeElementIDs fetch: (HeaperAsPosition make: value)) cast: IDRegion. result == NULL ifTrue: [Heaper BLAST: #DoesNotHaveAnID]. result count == 1 ifFalse: [Heaper BLAST: #HasMultipleIDs]. ^result theOne cast: ID! {IDRegion} iDsOf: value {BeRangeElement} "Find the IDs of a BeRangeElement, whether there are none, one, or several" | result {IDRegion | NULL} | result := (myRangeElementIDs fetch: (HeaperAsPosition make: value)) cast: IDRegion. result == NULL ifTrue: [^myGlobalIDSpace emptyRegion cast: IDRegion]. ^result! {BooleanVar} isAcceptingConnections "See FeAdminer" ^myAcceptingConnectionsFlag! {ID} newID ^myGlobalIDSpace newID! {IDSpace} newIDSpace "Make a new globally unique IDSpace" ^IDSpace make: self identifier with: myLocalIDSpaceCounter increment! {ID} placeOwnerID: iD {ID} "The ID of the Club which owns whatever is at the given ID" | value {BeRangeElement} | value := self fetch: iD. value ~~ NULL ifTrue: [^value owner]. Ravi shouldImplement "Figure out who owns PlaceHolders". ^NULL "fodder"! {void} setGateLockSmithEdition: edition {FeEdition} (FeLockSmith spec certify: edition) ifFalse: [Heaper BLAST: #MustBeValidLockSmith]. myGateLockSmithEdition := edition beEdition.! {ScruTable of: Sequence with: CrossRegion} wrapperEndorsements "A mapping from wrapper names to endorsements" Ravi thingToDo."Figure out if there is a better way to do this" ^myWrapperEndorsements! ! !BeGrandMap methodsFor: 'making editions'! {BeEdition} newDataEdition: values {PrimDataArray} with: keys {XnRegion} with: ordering {OrderSpec} "Creates an Edition mapping from a Region of keys to the values in an array. The ordering specifies the correspondance between the keys and the indices in the array. The Region must have the same count as the array. You must give an owner for the newly created DataHolders." | result {OrglRoot} offset {IntegerVar} remainder {XnRegion} | keys isEmpty ifTrue: [^self newEmptyEdition: keys coordinateSpace]. CurrentTrace fluidBind: myEnt newTrace during: [CurrentBertCrum fluidBind: BertCrum make during: [values count <= Ent tableSegmentMaxSize DOTasLong ifTrue: [^BeEdition make: (OrglRoot makeData: keys with: ordering with: values)]. result _ OrglRoot make.CoordinateSpace: ordering coordinateSpace. offset _ Int32Zero. remainder _ keys. [offset < values count] whileTrue: [| count {Int32} oroot {OrglRoot} array {PrimDataArray} region {XnRegion} | count _ Ent tableSegmentMaxSize DOTasLong min: values count - offset DOTasLong . array _ (values copy: count with: offset DOTasLong) cast: PrimDataArray. region _ remainder chooseMany: count with: ordering. oroot _ OrglRoot makeData: ((IntegerMapping make: offset negated) ofAll: region) with: ordering with: array. result _ result combine: (oroot transformedBy: (IntegerMapping make: offset)). remainder _ remainder minus: region. offset _ offset + count]. ^BeEdition make: result]]! {BeEdition} newEditionWith: key {Position} with: value {BeCarrier} "A single key-value mapping" [HistoryCrum] USES. Dean hack. "What should the bertCrum be?" CurrentTrace fluidBind: value rangeElement hCrum hCut newSuccessor during: [CurrentBertCrum fluidBind: value rangeElement bertCrum during: [| region {XnRegion} | region _ key asRegion. ^BeEdition make: (ActualOrglRoot make: (Loaf make.Region: region with: value) with: region)]]! {BeEdition} newEditionWithAll: keys {XnRegion} with: value {BeCarrier} "A single key-value mapping" Dean hack. "What should the bertCrum be?" keys isEmpty ifTrue: [^self newEmptyEdition: keys coordinateSpace]. CurrentTrace fluidBind: value rangeElement hCrum hCut newSuccessor during: [CurrentBertCrum fluidBind: value rangeElement bertCrum during: [^BeEdition make: (ActualOrglRoot make: (Loaf make.Region: keys with: value) with: keys)]]! {BeEdition} newEmptyEdition: cs {CoordinateSpace} "Create an empty Edition. This should really be canonicalized." CurrentTrace fluidBind: myEnt newTrace during: [ CurrentBertCrum fluidBind: BertCrum make during: [ DiskManager consistent: 4 with: [ ^BeEdition make: (OrglRoot make.CoordinateSpace: cs)]]]! {BeEdition} newPlaceHolders: region {XnRegion} "Make an Edition with a region full of unique PlaceHolders" Ravi thingToDo. "rename to newPlaceHolders" region isEmpty ifTrue: [^self newEmptyEdition: region coordinateSpace]. CurrentTrace fluidBind: myEnt newTrace during: [CurrentBertCrum fluidBind: BertCrum make during: [^BeEdition make: (OrglRoot make.XnRegion: region)]]! {BeEdition} newValueEdition: values {PtrArray of: FeRangeElement} with: keys {XnRegion} with: ordering {OrderSpec} "Creates an Edition mapping from a Region of keys to the values in an array. The ordering specifies the correspondance between the keys and the indices in the array. The Region must have the same count as the array." "compute the join of the existing traces and bert crums in the table" "make new ones if there are none" | trace {TracePosition} crum {CanopyCrum} rangeElement {BeRangeElement} | keys count ~~ values count ifTrue: [Heaper BLAST: #CountMismatch]. keys isEmpty ifTrue: [^self newEmptyEdition: keys coordinateSpace]. (values fetch: Int32Zero) notNULL: [:fe {FeRangeElement} | rangeElement _ fe getOrMakeBe] else: [Heaper BLAST: #MustNotHaveNullElements]. trace _ rangeElement hCrum hCut. crum _ rangeElement bertCrum. 1 almostTo: values count do: [:i {Int32} | (values fetch: i) notNULL: [:fe {FeRangeElement} | rangeElement _ fe getOrMakeBe] else: [Heaper BLAST: #MustNotHaveNullElements]. "Neither of these should need a consistent block." trace _ trace newSuccessorAfter: rangeElement hCrum hCut. crum _ crum computeJoin: rangeElement bertCrum]. CurrentTrace fluidBind: trace during: [CurrentBertCrum fluidBind: (crum cast: BertCrum) during: [ ^BeEdition make: (OrglRoot make: keys with: ordering with: values)]]! ! !BeGrandMap methodsFor: 'making other things'! {BeCarrier} carrier: element {BeRangeElement} "Return a carrier that has the rangeElement with a new Label if appropriate." (element isKindOf: BeEdition) ifTrue: [^BeCarrier make: self newLabel with: element] ifFalse: [^BeCarrier make: element]! {BeClub} newClub: desc {FeEdition} with: iD {ID default: NULL} "Make a new Club assigned to either iD or a generated ID id iD is NULL." | result {BeClub} | CurrentTrace fluidBind: myEnt newTrace during: [CurrentBertCrum fluidBind: BertCrum make during: [result := BeClub make: desc]]. DiskManager consistent: [iD == NULL ifTrue: [self assignID: result] ifFalse: [(self at: iD tryIntroduce: result) ifFalse: [Heaper BLAST: #IllegalID]]. "If we allow multiple IDs for clubs, we'll have to do this in the grandMap." result updateTransitiveMemberIDs. result updateTransitiveSuperClubIDs]. ^result! {BeDataHolder} newDataHolder: value {PrimValue} "Make a new DataHolder with the given contents." CurrentTrace fluidBind: myEnt newTrace during: [CurrentBertCrum fluidBind: BertCrum make during: [ DiskManager consistent: 1 with: [ ^BeDataHolder create: value]]]! {BeIDHolder} newIDHolder: iD {ID} "Make a new IDHolder for the given ID. Uses an existing one if it exists." | result {BeIDHolder} | result := (myIDHolders fetch: iD) cast: BeIDHolder. result == NULL ifTrue: [DiskManager consistent: [CurrentTrace fluidBind: myEnt newTrace during: [CurrentBertCrum fluidBind: BertCrum make during: [result := BeIDHolder make: iD. myIDHolders at: iD introduce: result]]]]. ^result! {BeLabel} newLabel "Make a new label." CurrentTrace fluidBind: myEnt newTrace during: [CurrentBertCrum fluidBind: BertCrum make during: [ DiskManager consistent: 1 with: [^BeLabel create]]]! {BePlaceHolder} newPlaceHolder "Make a new PlaceHolder." CurrentTrace fluidBind: myEnt newTrace during: [CurrentBertCrum fluidBind: BertCrum make during: [DiskManager consistent: 3 with: [^BePlaceHolder create]]]! {BeWork} newWork: contents {FeEdition} "Make a new Work (without an ID) with the given contents. Everything else comes from the fluid environment." CurrentTrace fluidBind: myEnt newTrace during: [CurrentBertCrum fluidBind: BertCrum make during: [^BeWork make: contents]]! ! !BeGrandMap methodsFor: 'clubs'! {ID} accessClubID ^myAccessClubID! {ID} adminClubID ^myAdminClubID! {ID} archiveClubID ^myArchiveClubID! {ID} emptyClubID ^myEmptyClubID! {ID} publicClubID ^myPublicClubID! ! !BeGrandMap methodsFor: 'smalltalk: defaults'! {BeClub} newClub: desc {FeEdition} ^self newClub: desc with: NULL! ! !BeGrandMap methodsFor: 'smalltalk: passe'! {FeRangeElement} getOrMakeFe: iD {ID} "Get what is at the the given ID as a front end object; if there is nothing there, then make the appropriate PlaceHolder" | result {BeRangeElement} | result := self fetch: iD. self knownBug. "This doesn't supply a label for Editions." result ~~ NULL ifTrue: [^result makeFe: NULL] ifFalse: [^FePlaceHolder grand: iD]! {IDSpace} iDSpace: identifier {Sequence} "Recreate an old IDSpace from externally stored numbers" self passe "IDSpace::import"! ! !BeGrandMap methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myIdentifier _ receiver receiveHeaper. myGlobalIDSpace _ receiver receiveHeaper. myLocalIDSpaceCounter _ receiver receiveHeaper. myGlobalIDFilterSpace _ receiver receiveHeaper. myEndorsementSpace _ receiver receiveHeaper. myEndorsementFilterSpace _ receiver receiveHeaper. myIDHolders _ receiver receiveHeaper. myIDCounters _ receiver receiveHeaper. myRangeElements _ receiver receiveHeaper. myRangeElementIDs _ receiver receiveHeaper. myEnt _ receiver receiveHeaper. myEmptyClubID _ receiver receiveHeaper. myPublicClubID _ receiver receiveHeaper. myAdminClubID _ receiver receiveHeaper. myArchiveClubID _ receiver receiveHeaper. myAccessClubID _ receiver receiveHeaper. myClubDirectoryID _ receiver receiveHeaper. myGateLockSmithEdition _ receiver receiveHeaper. myWrapperEndorsements _ receiver receiveHeaper. myEndorsementFlags _ receiver receiveHeaper. myGrants _ receiver receiveHeaper. self restartBeGrandMap: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myIdentifier. xmtr sendHeaper: myGlobalIDSpace. xmtr sendHeaper: myLocalIDSpaceCounter. xmtr sendHeaper: myGlobalIDFilterSpace. xmtr sendHeaper: myEndorsementSpace. xmtr sendHeaper: myEndorsementFilterSpace. xmtr sendHeaper: myIDHolders. xmtr sendHeaper: myIDCounters. xmtr sendHeaper: myRangeElements. xmtr sendHeaper: myRangeElementIDs. xmtr sendHeaper: myEnt. xmtr sendHeaper: myEmptyClubID. xmtr sendHeaper: myPublicClubID. xmtr sendHeaper: myAdminClubID. xmtr sendHeaper: myArchiveClubID. xmtr sendHeaper: myAccessClubID. xmtr sendHeaper: myClubDirectoryID. xmtr sendHeaper: myGateLockSmithEdition. xmtr sendHeaper: myWrapperEndorsements. xmtr sendHeaper: myEndorsementFlags. xmtr sendHeaper: myGrants.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BeGrandMap class instanceVariableNames: ''! (BeGrandMap getOrMakeCxxClassDescription) friends: 'friend class BackendBootMaker; '; attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !BeGrandMap class methodsFor: 'private: pseudo constructors'! make ^self create: (Sequence two: 666 with: 42)! ! !BeGrandMap class methodsFor: 'smalltalk: init'! staticTimeNonInherited BeGrandMap defineFluid: #CurrentGrandMap with: DiskManager emulsion with: [NULL]! ! !BeGrandMap class methodsFor: 'global: time'! {IntegerVar} xuTime "Seconds since the beginning of time" self knownBug. 'return 3;' translateOnly. [^Time xuTime] smalltalkOnly! !Abraham subclass: #BeRangeElement instanceVariableNames: ' myHCrum {HUpperCrum} mySensorCrum {SensorCrum} myOwner {ID} myFeRangeElements {PrimSet NOCOPY | NULL of: FeRangeElement}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Basic'! BeRangeElement comment: 'This is the actual representation on disk; the Fe versions of these classes hide the actual representation.ó'! (BeRangeElement getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #COPY; add: #SHEPHERD.ANCESTOR; add: #DEFERRED.LOCKED; yourself)! !BeRangeElement methodsFor: 'accessing'! {void} addFeRangeElement: element {FeRangeElement} "Add a new session level pointer" myFeRangeElements == NULL ifTrue: [myFeRangeElements := PrimSet weak]. myFeRangeElements introduce: element! {BooleanVar} isPurgeable ^myFeRangeElements == NULL or: [myFeRangeElements isEmpty]! {FeRangeElement} makeFe: label {BeLabel | NULL} "Make a front end object (session level) for this backend object. If the receiver is an Edition, there had better be a label." self subclassResponsibility! {BooleanVar} makeIdentical: other {BeRangeElement unused} "Change the identity of this object to that of the other. Only placeHolders implement it at the moment, so the default is to reject the operation (return false)." ^false! {ID} owner "The Club who has ownership" ^myOwner! {void} removeFeRangeElement: element {FeRangeElement} "Remove a session level pointer" (myFeRangeElements == NULL or: [(myFeRangeElements hasMember: element) not]) ifTrue: [Heaper BLAST: #NeverAddedFeRangeElement]. myFeRangeElements wipe: element. myFeRangeElements isEmpty ifTrue: [myFeRangeElements destroy. myFeRangeElements := NULL]! {void} setOwner: club {ID} "Change the Club who has ownership" DiskManager consistent: 1 with: [myOwner := club. self diskUpdate]! ! !BeRangeElement methodsFor: 'be accessing'! {void} addOParent: oparent {Loaf} "add oparent to the set of upward pointers. Editions may also have to propagate BertCrum change downward." DiskManager insistent: 5 with: [myHCrum isEmpty ifTrue: [self remember]. myHCrum addOParent: oparent. self diskUpdate]! {BooleanVar} anyPasses: finder {PropFinder} ^myHCrum anyPasses: finder! {BertCrum} bertCrum ^ myHCrum bertCrum! {void} checkRecorders: finder {PropFinder} with: scrum {SensorCrum | NULL} "does nothing. Overrides do something."! {UInt32} contentsHash ^((super contentsHash bitXor: myHCrum hashForEqual) bitXor: mySensorCrum hashForEqual) bitXor: myOwner hashForEqual! {void} delayedStoreBackfollow: finder {PropFinder} with: fossil {RecorderFossil} with: recorder {ResultRecorder} with: hCrumCache {HashSetCache of: HistoryCrum} myHCrum delayedStoreBackfollow: finder with: fossil with: recorder with: hCrumCache! {PrimSet of: FeRangeElement} feRangeElements myFeRangeElements == NULL ifTrue: [^PrimSet make] ifFalse: [^myFeRangeElements]! {HistoryCrum} hCrum ^myHCrum! {BooleanVar} inTrace: trace {TracePosition} "Return true if the receiver can backfollow to trace." ^myHCrum inTrace: trace! {Mapping} mappingTo: trace {TracePosition} with: mapping {Mapping} "return a mapping from my data to corresponding stuff in the given trace" ^myHCrum mappingTo: trace with: mapping! {void} removeOParent: oparent {OPart} "remove oparent from the set of upward pointers." myHCrum removeOParent: oparent. self diskUpdate. "myHCrum isEmpty ifTrue: [""Now we get into the risky part of deletion. myHCrum canForget iff all the downward pointers to it are gone."" self destroy]"! {SensorCrum} sensorCrum ^mySensorCrum! {BooleanVar} updateBCrumTo: newBCrum {BertCrum} "Ensure the my bertCrum is not be leafward of newBCrum." (myHCrum propagateBCrum: newBCrum) ifTrue: [self diskUpdate. ^true]. ^false! ! !BeRangeElement methodsFor: 'protected:'! create super create. myOwner _ InitialOwner fluidGet. myHCrum _ HUpperCrum make. mySensorCrum _ SensorCrum make. myFeRangeElements _ NULL! create: sensorCrum {SensorCrum} super create. myOwner _ InitialOwner fluidGet. myHCrum _ HUpperCrum make. mySensorCrum _ sensorCrum. myFeRangeElements _ NULL! {void} dismantle DiskManager consistent: 2 with: [(Heaper isConstructed: mySensorCrum) ifTrue: [mySensorCrum removePointer: self]. ((Heaper isConstructed: myHCrum) and: [Heaper isConstructed: myHCrum bertCrum]) ifTrue: [myHCrum bertCrum removePointer: myHCrum]. myHCrum _ NULL. super dismantle]! ! !BeRangeElement methodsFor: 'hooks:'! {void RECEIVE.HOOK} restartRE: rcvr {Rcvr unused} myFeRangeElements _ NULL! ! !BeRangeElement methodsFor: 'smalltalk:'! inspect "Sensor leftShiftDown" true ifTrue: [self basicInspect] ifFalse: [EntView openOn: (TreeBarnacle new buildOn: self gettingChildren: [:crum | crum crums] gettingImage: [:crum | DisplayText text: crum displayString asText textStyle: (TextStyle styleNamed: #small)] at: 0 @ 0 vertical: true separation: 5 @ 10)]! ! !BeRangeElement methodsFor: 'comparing'! {BeEdition} works: permissions {IDRegion} with: endorsementsFilter {Filter} with: flags {Int32} "See comment in FeRangeElement" MarkM shouldImplement. ^NULL "fodder"! ! !BeRangeElement methodsFor: 'smalltalk: passe'! {BooleanVar} becomeOther: other {BeRangeElement} self passe "makeIdentical"! {void} checkRecorders: edition {BeEdition} with: finder {PropFinder} with: scrum {SensorCrum | NULL} self passe "fewer args"! {void} delayedStoreBackfollow: finder {PropFinder} with: recorder {RecorderFossil} with: hCrumCache {HashSetCache of: HistoryCrum} self passe "extra argument"! {void} storeBackfollow: finder {PropFinder} with: table {MuTable of: ID and: BeEdition} with: hCrumCache {HashSetCache of: HistoryCrum} self passe! ! !BeRangeElement methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myHCrum _ receiver receiveHeaper. mySensorCrum _ receiver receiveHeaper. myOwner _ receiver receiveHeaper. self restartRE: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myHCrum. xmtr sendHeaper: mySensorCrum. xmtr sendHeaper: myOwner.! !BeRangeElement subclass: #BeDataHolder instanceVariableNames: 'myValue {PrimValue}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Basic'! (BeDataHolder getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !BeDataHolder methodsFor: 'accessing'! {FeRangeElement} makeFe: label {BeLabel | NULL} "Return me wrapped with a session level DataHolder." ^FeDataHolder on: self! {PrimValue} value ^myValue! ! !BeDataHolder methodsFor: 'create'! create: value {PrimValue} super create. myValue := value. self newShepherd! ! !BeDataHolder methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myValue _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myValue.! !BeRangeElement subclass: #BeEdition instanceVariableNames: ' myOrglRoot {OrglRoot} myWorks {MuSet of: BeWork} myOwnProp {BertProp} myProp {BertProp} myDetectors {(PrimSet NOCOPY of: FeFillRangeDetector) | NULL}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Basic'! (BeEdition getOrMakeCxxClassDescription) friends: 'friend class Matcher; '; attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !BeEdition methodsFor: 'operations'! {BeEdition} combine: other {BeEdition} "An Edition with the contents of both Editions; where they share keys, they must have the same RangeElement." other isEmpty ifTrue: [^self]. self isEmpty ifTrue: [^other]. "Eventually trace coordinates should be delayed." [HistoryCrum] USES. [TracePosition] USES. [Ent] USES. CurrentTrace fluidBind: (self hCrum hCut newSuccessorAfter: other hCrum hCut) during: [CurrentBertCrum fluidBind: BertCrum make during: [^BeEdition make: (myOrglRoot combine: other orglRoot)]]! {BeEdition} copy: keys {XnRegion} "A new Edition with the domain restricted to the given set of keys." CurrentTrace fluidBind: self hCrum hCut newSuccessor during: [CurrentBertCrum fluidBind: BertCrum make during: [^BeEdition make: (myOrglRoot copy: keys)]]! {BeEdition} replace: other {BeEdition} "An Edition with the contents of both Editions; where they share keys, use the contents of the other Edition. Equivalent to this->copy (other->domain ()->complement ())->combine (other)" self thingToDo. "This should be implemented directly." ^(self copy: other domain complement) combine: other! {BeEdition} transformedBy: mapping {Mapping} "An Edition with the keys transformed according to the given Mapping. Where the Mapping takes several keys in the domain to a single key in the range, this Edition must have the same RangeElement at all the domain keys." | resultRoot {OrglRoot} domain {XnRegion} | mapping cast: Dsp into: [:dsp | dsp isIdentity ifTrue: [^self]. CurrentTrace fluidBind: self hCrum hCut newSuccessor during: [CurrentBertCrum fluidBind: BertCrum make during: [^BeEdition make: (myOrglRoot transformedBy: dsp)]]] others: ["The rest of the method"]. CurrentTrace fluidBind: self hCrum hCut newSuccessor during: [CurrentBertCrum fluidBind: BertCrum make during: [domain _ myOrglRoot simpleDomain. resultRoot _ OrglRoot make.CoordinateSpace: mapping rangeSpace. mapping simpleMappings stepper forEach: [:simple {Mapping} | | common {XnRegion} | common _ domain intersect: simple domain. common isEmpty ifFalse: [ | dsp {Dsp} | (dsp _ simple fetchDsp) ~~ NULL ifTrue: [resultRoot _ resultRoot combine: ((myOrglRoot copy: common) transformedBy: dsp)] ifFalse: [self unimplemented]]]. ^BeEdition make: resultRoot]]! {BeEdition} with: key {Position} with: value {BeCarrier} "A new Edition with a RangeElement at a specified key. The old value, if there is one, is superceded. Equivalent to this->replace (theServer ()->makeEditionWith (key, value))" ^self replace: (CurrentGrandMap fluidGet newEditionWith: key with: value)! {BeEdition} withAll: keys {XnRegion} with: value {BeCarrier} "A new Edition with a RangeElement at a specified set of keys. The old values, if there are any, are superceded. Equivalent to this->replace (theServer ()->makeEditionWithAll (keys, value))" ^self replace: (CurrentGrandMap fluidGet newEditionWithAll: keys with: value)! {BeEdition} without: key {Position} "A new Edition without any RangeElement at a specified key. The old value, if there is one, is removed. Equivalent to this->copy (key->asRegion ()->complement ())" ^self copy: key asRegion complement! {BeEdition} withoutAll: keys {XnRegion} "A new Edition without any RangeElements at the specified keys. The old values, if there are any, are removed. Equivalent to this->copy (keys->complement ())" ^self copy: keys complement! ! !BeEdition methodsFor: 'accessing'! {CoordinateSpace} coordinateSpace "The space from which the keys of this Edition are taken. Equivalent to this->domain ()->coordinateSpace ()" ^myOrglRoot coordinateSpace! {IntegerVar} count "The number of keys in this Edition. Blasts if infinite. Equivalent to this->domain ()->count ()" ^myOrglRoot count! {XnRegion} domain "All the keys in this Edition. May be infinite, or empty." ^myOrglRoot domain! {FeRangeElement | NULL} fetch: key {Position} "Create a front end representation for what is at the given key." ^myOrglRoot fetch: key with: self! {FeRangeElement} get: key {Position} "The value at the given key, or blast if there is no such key (i.e. if !! this->domain ()->hasMember (key))." | result {FeRangeElement | NULL} | result _ self fetch: key. result == NULL ifTrue: [Heaper BLAST: #NotInTable]. ^result! {BooleanVar} includesKey: key {Position} "Whether the given key is in the Edition. Equivalent to this->domain ()->hasMember (key)" ^(myOrglRoot fetch: key with: self) ~~ NULL! {BooleanVar} isEmpty "Whether there are any keys in this Edition. Equivalent to this->domain ()->isEmpty ()" ^myOrglRoot isEmpty! {BooleanVar} isFinite "Whether there is a finite number of keys in this Edition. Equivalent to this->domain ()->isFinite ()" ^myOrglRoot simpleDomain isFinite or: [myOrglRoot domain isFinite]! {BooleanVar} isPurgeable ^super isPurgeable and: [myDetectors == NULL]! {FeRangeElement} makeFe: label {BeLabel | NULL} ^FeEdition on: self with: (FeLabel on: label)! {IDRegion} rangeOwners: positions {XnRegion default: NULL} "The owners of all the RangeElements in the given Region, or in the entire Edition if no Region is specified." ^(myOrglRoot rangeOwners: positions) cast: IDRegion! {(Stepper of: Bundle) CLIENT} retrieve: region {XnRegion default: NULL} with: order {OrderSpec default: NULL} with: flags {Int32 default: Int32Zero} "Essential. This is the fundamental retrieval operation. Return a stepper of bundles. Each bundle is an association between a region in the domain and the range elements associated with that region. Where the region is associated with data, for instance, the bundle contains a PrimArray of the data elements. If no Region is given, then reads out the whole thing." | theRegion {XnRegion} theOrder {OrderSpec} result {Accumulator} | self thingToDo. "The above comment is horribly insufficient." self thingToDo. "This desperately needs to splay the region." region == NULL ifTrue: [theRegion _ myOrglRoot simpleDomain] ifFalse: [theRegion _ region]. theRegion isEmpty ifTrue: [^Stepper emptyStepper]. order == NULL ifTrue: [theOrder := theRegion coordinateSpace getAscending] ifFalse: [theOrder := order]. "generate everything at once to avoid problems with the data structures changing as the client steps" result := Accumulator ptrArray. (myOrglRoot bundleStepper: theRegion with: theOrder) forEach: [:bundle {Heaper} | result step: bundle]. ^TableStepper ascending: (result value cast: PtrArray)! {FeRangeElement} theOne "If this Edition has a single key, then the value at that key; if not, blasts. Equivalent to this->get (this->domain ()->theOne ())" ^self get: self domain theOne! {CrossRegion} visibleEndorsements "All of the endorsements on this Edition and all Works which the CurrentKeyMaster can read." | result {XnRegion} | result := myOwnProp endorsements. myWorks stepper forEach: [ :work {BeWork} | (work canBeReadBy: CurrentKeyMaster fluidGet) ifTrue: [result := result unionWith: work endorsements]]. ^result cast: CrossRegion! ! !BeEdition methodsFor: 'props'! {void} endorse: endorsements {CrossRegion} "Adds to the endorsements on this Edition. The set of endorsements must be a finite number of (club ID, token ID) pairs." endorsements isEmpty ifTrue: [^VOID]. DiskManager consistent: 8 with: [self propChange: PropChange endorsementsChange with: (BertProp endorsementsProp: (endorsements unionWith: myProp endorsements))]! {CrossRegion} endorsements "All of the endorsements on this Edition." ^myOwnProp endorsements cast: CrossRegion! {BertProp} prop ^myProp! {void} propChange: change {PropChange} with: nw {Prop} | old {Prop} | old _ myOwnProp. (change areEqualProps: old with: nw) not ifTrue: [DiskManager consistent: 6 with: [myOwnProp _ (change changed: old with: nw) cast: BertProp. self diskUpdate. self propChanged: change with: old with: nw]]! {void} propChanged: change {PropChange} with: old {Prop} with: nw {Prop} with: oldFinder {PropFinder default: NULL} "update props" | newProp {Prop} | "Attempt to apply the change directly to the current set of properties. If that removes some property look at all the berts to see if we get it from somewhere else. (BIG and not currently log.) If the new properties are different than the old ones we must change, so remember the current props In a consistent block change the props on the stamp change leaf of bert canopy and create an AgendaItem to propagate the chage through bert canopy fetch a finder to look for recorders rung by this change in props See if permissions decrease: If so, recorders can't be rung. Don't bother with sensor canopy, just schedule bert canopy propagation. If not make an AgendaItem to check for recorders in the sensor canopy make and schedule a Sequencer to do the bert then the sensor canopy AgendaItems." newProp _ change changed: myProp with: myOwnProp. newProp _ change with: newProp with: nw. (change areEqualProps: newProp with: (change with: newProp with: old)) not ifTrue: [myWorks stepper forEach: [:work {BeWork} | self thingToDo. "Make it log." newProp _ change with: newProp with: work localProp]]. (change areEqualProps: myProp with: newProp) ifFalse: [| before {BertProp} finder {PropFinder} changer {AgendaItem} checker {AgendaItem} | before _ myProp. DiskManager consistent: 9 with: [myProp _ (newProp cast: BertProp). self diskUpdate. changer _ myOrglRoot propChanger: change. finder _ change fetchFinder: before with: myProp with: self with: oldFinder. finder == NULL ifTrue: [changer schedule] ifFalse: [checker _ SouthRecorderChecker make: myOrglRoot with: finder with: (myOrglRoot sensorCrum fetchParent cast: SensorCrum). oldFinder == NULL ifTrue: [(Sequencer make: changer with: checker) schedule] ifFalse: [ | workChecker {AgendaItem} | workChecker := NorthRecorderChecker make: self with: finder. "the sequence of workChecker vs checker doesn't matter" (Sequencer make: changer with: (Sequencer make: workChecker with: checker)) schedule]]]]! {void} retract: endorsements {CrossRegion} "Removes endorsements from this Edition. Ignores all endorsements which you could have removed, but which don't happen to be there right now." endorsements isEmpty ifTrue: [^VOID]. DiskManager consistent: 4 with: [self propChange: PropChange endorsementsChange with: (BertProp endorsementsProp: (myOwnProp endorsements minus: endorsements))]! {CrossRegion} totalEndorsements "All of the endorsements on this Edition and all Works directly on it" | result {XnRegion} | result := myOwnProp endorsements. myWorks stepper forEach: [ :work {BeWork} | result := result unionWith: work endorsements]. ^result cast: CrossRegion! ! !BeEdition methodsFor: 'becoming'! {void} addDetector: detect {FeFillRangeDetector} "Add a detector which will be triggered with a FeEdition when a PlaceHolder becomes a non-PlaceHolder" myDetectors == NULL ifTrue: [myDetectors := PrimSet weak: 7 with: (BeEditionDetectorExecutor make: self). self propChange: PropChange detectorWaitingChange with: BertProp detectorWaitingProp]. myDetectors introduce: detect. myOrglRoot triggerDetector: detect.! {ID} ownerAt: key {Position} "Return the owner for the given position in the receiver." ^myOrglRoot ownerAt: key! {void} removeDetector: detect {FeFillRangeDetector} "Remove a previously added detector" (Heaper isDestructed: myDetectors) ifTrue: [^VOID]. myDetectors == NULL ifTrue: [Heaper BLAST: #NeverAddedDetector]. Ravi knownBug. "if we're in GC, we may be dealing with a partially unconstructed web of objects" myDetectors remove: detect. myDetectors isEmpty ifTrue: [myDetectors := NULL. self propChange: PropChange detectorWaitingChange with: BertProp make]! {void} removeLastDetector "Notify the edition that there are no remaining detectors on it." myDetectors := NULL. self propChange: PropChange detectorWaitingChange with: BertProp make! {void} ringDetectors: newIdentities {FeEdition} "Ring all my detectors with the given Edition as an argument" myDetectors ~~ NULL ifTrue: [myDetectors stepper forEach: [ :det {FeFillRangeDetector} | det rangeFilled: newIdentities]]! {BeEdition} setRangeOwners: newOwner {ID} with: region {XnRegion} "Changes the owner of all RangeElements; requires the authority of the current owner. Returns the subset of this Edition whose owners did not get changed because of lack of authority." self knownBug. "Must be a loop in ServerLoop." self thingToDo. "propagate region down through the algorithm?" CurrentTrace fluidBind: self hCrum hCut newSuccessor during: [CurrentBertCrum fluidBind: BertCrum make during: [^BeEdition make: ((myOrglRoot copy: region) setAllOwners: newOwner)]]! {Pair of: BeEdition} tryAllBecome: newIdentities {BeEdition} "Change the identities of the RangeElements of this Edition to those at the same key in the other Edition. The left piece of the result contains those object which are know to not be able to become, because of - lack of ownership authority - different contents - incompatible types - no corresponding new identity The right piece of the result is NULL if there is nothing more that might be done, or else the remainder of the receiver on which we might be able to proceed. This material might fail at a later time because of any of the reasons above; or it might succeed , even though it failed this time because of - synchronization problem - just didn't feel like it This is always required to make progress if it can, although it isn't required to make all the progress that it might. Returns right=NULL when it can't make further progress." Dean shouldImplement. ^NULL "fodder"! ! !BeEdition methodsFor: 'labelling'! {XnRegion} keysLabelled: label {BeLabel} "The keys in this Edition at which there are Editions with the given label." ^myOrglRoot keysLabelled: label! {BeEdition} rebind: key {Position} with: edition {BeEdition} "Replace the Edition at the given key, leaving the Label the same. Equivalent to this->store (key, edition->labelled (CAST(FeEdition,this->get (key))->label ()))" self mightNotImplement. ^NULL "fodder"! ! !BeEdition methodsFor: 'hooks:'! {void RECEIVE.HOOK} restartE: rcvr {Rcvr unused} myDetectors _ NULL! ! !BeEdition methodsFor: 'protected:'! {OrglRoot} orglRoot ^myOrglRoot! ! !BeEdition methodsFor: 'be accessing'! {void} addOParent: oparent {Loaf} "add oparent to the set of upward pointers. Editions may also have to propagate BertCrum change downward." | bCrum {BertCrum} newBCrum {BertCrum} | [HistoryCrum] USES. bCrum _ self hCrum bertCrum. super addOParent: oparent. newBCrum _ self hCrum bertCrum. (bCrum isLE: newBCrum) ifFalse: [myOrglRoot updateBCrumTo: newBCrum]! {BooleanVar} anyPasses: finder {PropFinder} | next {PropFinder} | next := finder findPast: self. ^next isFull or: [super anyPasses: next]! {void} checkRecorders: finder {PropFinder} with: scrum {SensorCrum | NULL} | newFinder {PropFinder} | "Get a new finder which remembers to check if recorders will newly find me" newFinder _ finder findPast: self. "replace endorsements with those in the prop" newFinder isEmpty ifFalse: ["keep looking down, with my stamp as the new reference point" self thingToDo. "Use the new finder to check all recorders beneath me, checking whether they record all stamps from me all the way up to the stamp passed in as an argument" Ravi knownBug. "using scrum's parent records things twice" (SouthRecorderChecker make: myOrglRoot with: newFinder with: (scrum fetchParent cast: SensorCrum)) schedule]! {ImmuSet of: BeWork} currentWorks "The Works currently on this Edition" ^myWorks asImmuSet! {BeRangeElement} getOrMakeBe: key {Position} "An actual, non-virtual FE range element at that key. Used by become operation to get something to pass into BeRangeElement::become ()" ^myOrglRoot getBe: key! {void} introduceWork: work {BeWork} "A Work has been newly revised to point at me." DiskManager consistent: [myWorks introduce: work. self diskUpdate. self propChanged: PropChange bertPropChange with: BertProp make with: work prop with: (PropChange bertPropChange fetchFinder: BertProp make with: work prop with: work with: NULL)]. (myWorks count >= 100 and: [(myWorks isKindOf: GrandHashSet) not]) ifTrue: [| newWorks {MuSet} | newWorks _ GrandHashSet make. myWorks stepper forEach: [:b {BeWork} | newWorks store: b]. DiskManager consistent: 1 with: [myWorks _ newWorks. self diskUpdate]].! {void} removeWork: work {BeWork} "The Work is no longer onto this Edition. Remove the backpointer." DiskManager consistent: [myWorks remove: work. self diskUpdate. self propChanged: PropChange bertPropChange with: work prop with: BertProp make]! {BooleanVar} updateBCrumTo: newBCrum {BertCrum} "My bertCrum must not be leafward of newBCrum. Thus it must be LE to newCrum. Otherwise correct it and recur." (super updateBCrumTo: newBCrum) ifTrue: [myOrglRoot updateBCrumTo: newBCrum. ^true]. ^false! ! !BeEdition methodsFor: 'comparing'! {XnRegion} keysOf: value {FeRangeElement} "All of the keys in this Edition at which the given RangeElement can be found. Equivalent to this->sharedRegion (theServer ()->makeEditionWith (some position, value))" [BeGrandMap] USES. ^self sharedRegion: (CurrentGrandMap fluidGet newEditionWith: IntegerPos zero with: value carrier)! {Mapping} mapSharedTo: other {BeEdition} "A Mapping from each of the keys in this Edition to all of the keys in the other Edition which have the same RangeElement." ^myOrglRoot mapSharedTo: other hCrum hCut! {BeEdition} notSharedWith: other {BeEdition} with: flags {Int32 default: Int32Zero} "The subset of this Edition whose RangeElements are not in the other Edition. Equivalent to this->copy (this->sharedRegion (other, flags)->complement ())" ^self copy: (self sharedRegion: other with: flags) complement! {XnRegion} sharedRegion: other {BeEdition} with: flags {Int32 default: Int32Zero} "The subset of the keys of this Edition which have RangeElements that are in the other Edition. If both flags are false, then equivalent to this->mapSharedTo (other)->domain () If nestThis, then returns not only keys of RangeElements which are in the other, but also keys of Editions which lead to RangeElements which are in the other. If nestOther, then looks not only for RangeElements which are values of the other Edition, but also those which are values of sub-Editions of the other Edition. (This option will probably not be supported in version 1.0)" flags ~= Int32Zero ifTrue: [self unimplemented]. ^myOrglRoot sharedRegion: other hCrum hCut! {BeEdition} sharedWith: other {BeEdition} with: flags {Int32 default: Int32Zero} "The subset of this Edition whose RangeElements are in the other Edition. If the same RangeElement is in this Edition at several different keys, all keys will be in the result (provided the RangeElement is also in the other Edition). Equivalent to this->copy (this->sharedRegion (other, flags))" ^self copy: (self sharedRegion: other with: flags)! {BeEdition} works: permissions {IDRegion} with: endorsementsFilter {Filter} with: flags {Int32} | result {Accumulator} iDSpace {IDSpace} region {XnRegion} | flags = (FeEdition LOCAL.U.PRESENT.U.ONLY bitOr: FeEdition DIRECT.U.CONTAINERS.U.ONLY) ifFalse: [^super works: permissions with: endorsementsFilter with: flags]. result := Accumulator ptrArray. myWorks stepper forEach: [ :work {BeWork} | (endorsementsFilter match: work endorsements) ifTrue: [result step: (work makeFe: NULL)]]. iDSpace := CurrentGrandMap fluidGet newIDSpace. region := (iDSpace newIDs: ((result value cast: PtrArray) count)). ^(CurrentGrandMap fluidGet newPlaceHolders: region complement) combine:(CurrentGrandMap fluidGet newValueEdition: (result value cast: PtrArray) with: region with: iDSpace ascending)! ! !BeEdition methodsFor: 'creation'! create: root {OrglRoot} super create: root sensorCrum. Dean knownBug. "this should not have the same SensorCrum as my OrglRoot" myOrglRoot _ root. myWorks _ MuSet make. "This should maybe just start out NULL." myOwnProp _ myProp _ BertProp make. myDetectors _ NULL. DiskManager consistent: 5 with: [myOrglRoot introduceEdition: self. self newShepherd]! {void} dismantle DiskManager consistent: "2 with: (need to recalculate for adding propChange)" [self propChange: PropChange bertPropChange with: BertProp make. (Heaper isConstructed: myOrglRoot) ifTrue: [myOrglRoot removeEdition: self]. myOrglRoot _ NULL. super dismantle]! ! !BeEdition methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '(' << myOrglRoot << ')'! ! !BeEdition methodsFor: 'transclusions'! {XnRegion} attachTrailBlazer: blazer {TrailBlazer} "Attach the TrailBlazer to this Edition, and return the region of partiality it is attached to" ^myOrglRoot attachTrailBlazer: blazer! {void} fossilRelease: oldGrabber {RecorderFossil} MarkM thingToDo. "myGrabbersFossil == NULL ifTrue: [Heaper BLAST: #NotGrabbed] ifFalse: [myGrabbersFossil ~~ oldGrabber ifTrue: [Heaper BLAST: #WhoIsReleasingMe] ifFalse: [DiskManager consistent: 2 with: [myGrabbersFossil := NULL. oldGrabber extinguish: self. self diskUpdate]]]"! {TrailBlazer} getOrMakeTrailBlazer "Get or make a TrailBlazer for recording results into this Edition. Blast if there is already more than one" | result {TrailBlazer} | result := myOrglRoot fetchTrailBlazer. result == NULL ifTrue: [^TrailBlazer make: self]. myOrglRoot checkTrailBlazer: result. ^result! {BeEdition} rangeTranscluders: region {XnRegion | NULL} with: directFilter {Filter} with: indirectFilter {Filter} with: flags {Int32} with: otherTrail {BeEdition | NULL} "See FeEdition" | fossil {RecorderFossil} result {BeEdition} | "Reject all the unimplemented cases. if a trail isn't given make a new one else use it as the result. Make a fossilized recorder snapshotting the current login authority filtered by the endorsementsFilter for recording into the trail Set the transclusions request in motion Return the trail" (flags bitAnd: (FeEdition DIRECT.U.CONTAINERS.U.ONLY bitOr: FeEdition LOCAL.U.PRESENT.U.ONLY) bitInvert) ~~ Int32Zero ifTrue: [self unimplemented]. otherTrail == NULL ifTrue: [result := CurrentGrandMap fluidGet newPlaceHolders: CurrentGrandMap fluidGet newIDSpace fullRegion] ifFalse: [result := otherTrail]. fossil := RecorderFossil transcluders: (flags bitAnd: FeEdition DIRECT.U.CONTAINERS.U.ONLY) ~~ Int32Zero with: CurrentKeyMaster fluidFetch loginAuthority with: directFilter with: indirectFilter with: result getOrMakeTrailBlazer. (flags bitAnd: FeEdition LOCAL.U.PRESENT.U.ONLY) ~~ Int32Zero ifTrue: [self scheduleImmediateBackfollow: fossil with: region] ifFalse: [(flags bitAnd: FeEdition DIRECT.U.CONTAINERS.U.ONLY) ~~ Int32Zero ifTrue: [self unimplemented]. self scheduleDelayedBackfollow: fossil with: region]. ^result! {BeEdition} rangeWorks: region {XnRegion | NULL} with: filter {Filter} with: flags {Int32} with: otherTrail {BeEdition | NULL} "See FeEdition" | fossil {RecorderFossil} result {BeEdition} | "Reject all the unimplemented cases. if a trail isn't given make a new one else use it as the result. Make a fossilized recorder snapshotting the current login authority filtered by the endorsementsFilter for recording into the trail Set the transclusions request in motion Return the trail" (flags bitAnd: (FeEdition DIRECT.U.CONTAINERS.U.ONLY bitOr: FeEdition LOCAL.U.PRESENT.U.ONLY) bitInvert) ~~ Int32Zero ifTrue: [self unimplemented]. otherTrail == NULL ifTrue: [result := CurrentGrandMap fluidGet newPlaceHolders: CurrentGrandMap fluidGet newIDSpace fullRegion] ifFalse: [result := otherTrail]. fossil := RecorderFossil works: (flags bitAnd: FeEdition DIRECT.U.CONTAINERS.U.ONLY) ~~ Int32Zero with: CurrentKeyMaster fluidGet loginAuthority with: filter with: result getOrMakeTrailBlazer. (flags bitAnd: FeEdition LOCAL.U.PRESENT.U.ONLY) ~~ Int32Zero ifTrue: [self scheduleImmediateBackfollow: fossil with: region] ifFalse: [(flags bitAnd: FeEdition DIRECT.U.CONTAINERS.U.ONLY) ~~ Int32Zero ifTrue: [self unimplemented]. self scheduleDelayedBackfollow: fossil with: region]. ^result! {void} scheduleDelayedBackfollow: fossil {RecorderFossil} with: region {XnRegion | NULL} "Walk down orgl's O-tree (onto range elements of interest) planting pointers to a Fossil of BackfollowRecorder in the sensor canopy and collecting agenda items to propagate their endorsement and permission filtering info rootward in the sensor canopy. Create and schedule a structure of AgendaItems to: - First: Do the filtering info propagation. - Second: Find and record any currently matching stamps. This is done in this order so collection of the future part of recorder information is completed before the present part is extracted, keeping significant information from falling through the crack." | rAgents {Agenda} matcher {AgendaItem} oroot {OrglRoot} | "Create an empty Agenda. Do the walk and collect PropChangers in the new Agenda. Reanimate the Fossil long enough to make a Matcher AgendaItem from the filtering information extracted from the Fossil Make and schedule a Sequencer that first runs the Agenda that propagates filtering info, then runs the Matcher." fossil isExtinct ifTrue: [^VOID]. rAgents _ Agenda make. region == NULL ifTrue: [oroot := myOrglRoot] ifFalse: [CurrentTrace fluidBind: self hCrum hCut newSuccessor during: [CurrentBertCrum fluidBind: BertCrum make during: [oroot := myOrglRoot copy: region]]]. oroot storeRecordingAgents: fossil with: rAgents. fossil reanimate: [:recorder {ResultRecorder} | matcher _ Matcher make: oroot with: recorder bertPropFinder with: fossil]. (Sequencer make: rAgents with: matcher) schedule! {void} scheduleImmediateBackfollow: fossil {RecorderFossil} with: region {XnRegion | NULL} "Find and record any currently matching Editions." | oroot {OrglRoot} | MarkM thingToDo. "When we are actually leaving AgendaItems on the queue, make sure that all necessary canopy propagation is done before the Matcher excutes" region == NULL ifTrue: [oroot := myOrglRoot] ifFalse: [CurrentTrace fluidBind: self hCrum hCut newSuccessor during: [CurrentBertCrum fluidBind: BertCrum make during: [oroot := myOrglRoot copy: region]]]. fossil reanimate: [:recorder {ResultRecorder} | (Matcher make: oroot with: recorder bertPropFinder with: fossil) schedule]! ! !BeEdition methodsFor: 'smalltalk: defaults'! {void} propChanged: change {PropChange} with: old {Prop} with: nw {Prop} self propChanged: change with: old with: nw with: NULL! {XnRegion} sharedRegion: other {BeEdition} ^self sharedRegion: other with: 0! ! !BeEdition methodsFor: 'smalltalk: passe'! {MuSet of: FeFillRangeDetector} detectors self passe! {BeRangeElement | NULL} fetchOrMakeBeRangeElement: key {Position} "An actual, non-virtual FE range element at that key. Used by become operation to get something to pass into BeRangeElement::become ()" self passe "no implementation, senders, or polymorphs - /ravi/10/7/92/"! {BeEdition} parcelAt: key {Position} self passe! {BeEdition} parcels self passe! {BeEdition PROXY} reorganize: oldRegion {XnRegion | NULL} with: oldOrder {OrderSpec | NULL} with: newRegion {XnRegion | NULL} with: newOrder {OrderSpec | NULL} "Rearrange the keys of this Edition to lie in the given region, with the given ordering. Equivalent to server->makeEdition (this->asArray (oldRegion, oldOrder), newRegion, newOrder, NULL), except that it doesn't require everything to be in the same zone (and is of course more efficient)." self unimplemented! {void} scheduleDelayedBackfollow: fossil {RecorderFossil} self passe! {void} scheduleImmediateBackfollow: fossil {RecorderFossil} self passe! {BeEdition} setAllOwners: newOwner {ID} self passe! {BeEdition} setAllOwners: newOwner {ID} with: region {XnRegion} self passe "setRangeOwners"! {void} unendorse: endorsements {CrossRegion} self passe "retract"! {void} wait: sensor {XnSensor} self passe! ! !BeEdition methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myOrglRoot _ receiver receiveHeaper. myWorks _ receiver receiveHeaper. myOwnProp _ receiver receiveHeaper. myProp _ receiver receiveHeaper. self restartE: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myOrglRoot. xmtr sendHeaper: myWorks. xmtr sendHeaper: myOwnProp. xmtr sendHeaper: myProp.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BeEdition class instanceVariableNames: ''! (BeEdition getOrMakeCxxClassDescription) friends: 'friend class Matcher; '; attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !BeEdition class methodsFor: 'creation'! make: oroot {OrglRoot} DiskManager consistent: 5 with: [^self create: oroot]! !BeRangeElement subclass: #BeIDHolder instanceVariableNames: 'myID {ID}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Basic'! (BeIDHolder getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !BeIDHolder methodsFor: 'accessing'! {ID} iD ^myID! {FeRangeElement} makeFe: label {BeLabel | NULL} ^FeIDHolder on: self! ! !BeIDHolder methodsFor: 'protected: dismantle'! {void} dismantle "Does this need to clear the GrandMap table?" self unimplemented! ! !BeIDHolder methodsFor: 'protected: creation'! create: iD {ID} super create. myID _ iD. self newShepherd! ! !BeIDHolder methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myID _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myID.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BeIDHolder class instanceVariableNames: ''! (BeIDHolder getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !BeIDHolder class methodsFor: 'creation'! make: iD {ID} ^ self create: iD! !BeRangeElement subclass: #BeLabel instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Basic'! (BeLabel getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !BeLabel methodsFor: 'accessing'! {FeRangeElement} makeFe: label {BeLabel | NULL} ^FeLabel on: self! ! !BeLabel methodsFor: 'creation'! create super create. self newShepherd. self hack. "Labels don't know when they're pointed to as labels instead of range elements, so just remember them." self remember! ! !BeLabel methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !BeRangeElement subclass: #BePlaceHolder instanceVariableNames: ' myTrailBlazer {TrailBlazer | NULL} myDetectors {PrimSet NOCOPY | NULL of: FeFillDetector}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Basic'! (BePlaceHolder getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !BePlaceHolder methodsFor: 'accessing'! {void} addDetector: detector {FeFillDetector} myDetectors == NULL ifTrue: [myDetectors := PrimSet weak: 7 with: (FillDetectorExecutor make: self)]. myDetectors store: detector! {BooleanVar} isPurgeable ^super isPurgeable and: [myDetectors == NULL]! {FeRangeElement} makeFe: label {BeLabel | NULL} ^FePlaceHolder on: self! {BooleanVar} makeIdentical: other {BeRangeElement} "Change the identity of this object to that of the other." "Make all my persistent oParents point at the other guy. make all the session level FeRangeElements point at the other guy." | oParents {ScruSet of: OPart} | oParents _ self hCrum oParents. self knownBug. "if there are several oParents then a given Detector may be rung more than once" DiskManager consistent: -1 with: [oParents stepper forEach: [:loaf {Loaf} | (loaf cast: RegionLoaf) forwardTo: other]]. self feRangeElements stepper forEach: [:elem {FePlaceHolder} | (elem cast: FeActualPlaceHolder) forwardTo: other]. myDetectors ~~ NULL ifTrue: [ | fe {FeRangeElement} | other cast: BeEdition into: [ :ed | fe := ed makeFe: CurrentGrandMap fluidGet newLabel] others: [fe := other makeFe: NULL]. myDetectors stepper forEach: [ :det {FeFillDetector} | det filled: fe]]. ^false "fodder"! {void} removeDetector: detector {FeFillDetector} (Heaper isDestructed: myDetectors) ifTrue: [^VOID]. myDetectors == NULL ifTrue: [Heaper BLAST: #NotInSet]. myDetectors remove: detector. myDetectors isEmpty ifTrue: [myDetectors := NULL].! {void} removeLastDetector myDetectors := NULL! ! !BePlaceHolder methodsFor: 'creation'! create super create: SensorCrum partial. myTrailBlazer := NULL. myDetectors := NULL. self newShepherd! create: blazer {TrailBlazer | NULL} super create: SensorCrum partial. myTrailBlazer := blazer. blazer ~~ NULL ifTrue: [blazer addReference: self]. myDetectors := NULL. self newShepherd! ! !BePlaceHolder methodsFor: 'backfollow'! {void} attachTrailBlazer: blazer {TrailBlazer} DiskManager consistent: 3 with: [myTrailBlazer ~~ NULL ifTrue: [myTrailBlazer isAlive ifTrue: [Heaper BLAST: #FatalError] ifFalse: [myTrailBlazer removeReference: self]]. myTrailBlazer := blazer. blazer addReference: self. self diskUpdate]! {void} checkTrailBlazer: blazer {TrailBlazer} (myTrailBlazer ~~ NULL and: [myTrailBlazer isEqual: blazer]) ifFalse: [Heaper BLAST: #InvalidTrail]! {TrailBlazer | NULL} fetchTrailBlazer (myTrailBlazer == NULL or: [myTrailBlazer isAlive]) ifTrue: [^myTrailBlazer]. "it was not successfully attached, so clean it up" DiskManager consistent: 2 with: [myTrailBlazer removeReference: self. myTrailBlazer := NULL. self diskUpdate. ^NULL]! ! !BePlaceHolder methodsFor: 'hooks:'! {void RECEIVE.HOOK} restartP: rcvr {Rcvr unused} myDetectors := NULL.! ! !BePlaceHolder methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myTrailBlazer _ receiver receiveHeaper. self restartP: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myTrailBlazer.! !BeRangeElement subclass: #BeWork instanceVariableNames: ' myEdition {BeEdition} myEditionLabel {BeLabel} myReadClub {ID | NULL} myEditClub {ID | NULL} myOwnProp {BertProp} myHistory {BeEdition | NULL} myHistoryClub {ID | NULL} myRevisionCount {IntegerVar} myRevisionTime {IntegerVar} myReviser {ID} mySponsors {IDRegion} myLockingWork {WeakPtrArray NOCOPY of: FeWork} myRevisionWatchers {PrimSet NOCOPY | NULL of: FeWork}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Basic'! BeWork comment: 'This is the actual representation on disk; the Fe versions of these classes hide the actual representation.ó'! (BeWork getOrMakeCxxClassDescription) friends: '/* friends for class BeWork */ friend class BeWorkLockExecutor;'; attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !BeWork methodsFor: 'locking'! {BooleanVar} canBeEditedBy: km {FeKeyMaster} "Answer whether the KeyMaster has the authority to edit this work." ^myEditClub ~~ NULL and: [km hasAuthority: myEditClub]! {BooleanVar} canBeReadBy: km {FeKeyMaster} "Return true if the KeyMaster has the authority to read this Work." ^(myReadClub ~~ NULL and: [km hasAuthority: myReadClub]) or: [self canBeEditedBy: km]! {FeWork INLINE | NULL} fetchLockingWork "The Work which has this locked, or NULL if noone does." ^(myLockingWork fetch: Int32Zero) cast: FeWork! {FeWork} makeLockedFeWork "Make a frontend Work on me and lock it if possible." | result {FeWork} ckm {FeKeyMaster} | result := (self makeFe: NULL) cast: FeWork. ckm := CurrentKeyMaster fluidGet. (self fetchLockingWork == NULL and: [self canBeEditedBy: ckm]) ifTrue: [result grab]. ^result! {BooleanVar} tryLock: work {FeWork} "Try to lock with the give FE Work. Return TRUE if successful" | curLock {FeWork} | curLock := self fetchLockingWork. (curLock == NULL or: [curLock isEqual: work]) ifTrue: [myLockingWork at: Int32Zero store: work. ^true] ifFalse: [^false]! {BooleanVar} tryUnlock: work {FeWork} "If the given FE Work is locking, then unlock and return TRUE; else return FALSE with no change in lock state" self fetchLockingWork == work ifTrue: ["Unlock and tell everyone about the change" myLockingWork at: Int32Zero store: NULL. self updateFeStatus. ^true] ifFalse: [^false]! ! !BeWork methodsFor: 'contents'! {void} addRevisionWatcher: work {FeWork} "Tell the FE Work whenever this Work is revised" myRevisionWatchers == NULL ifTrue: [myRevisionWatchers := PrimSet weak: 7 with: (RevisionWatcherExecutor make: self)]. myRevisionWatchers introduce: work! {FeEdition} edition "The current Edition. Note: If this is an unsponsored Work, the Edition might have been discarded, and this operation will blast." self thingToDo. "Cache this" ^FeEdition on: myEdition with: (FeLabel on: myEditionLabel)! {ID} lastRevisionAuthor "The Club who made the last revision" ^myReviser! {IntegerVar} lastRevisionNumber "The sequence number of the last revision of this Work." ^myRevisionCount! {IntegerVar} lastRevisionTime "The time of the last revision of this Work." ^myRevisionTime! {void} recordHistory "Change the current edition and notify anyone who cares about the revision" | gm {BeGrandMap} | myHistoryClub == NULL ifTrue: [^VOID]. gm _ CurrentGrandMap fluidGet. "Bind all these because they not be set." InitialReadClub fluidBind: myHistoryClub during: [InitialEditClub fluidBind: gm emptyClubID during: [InitialOwner fluidBind: self owner during: [InitialSponsor fluidBind: gm emptyClubID during: "Don't sponsor the history." [| legacy {BeWork} | legacy _ gm newWork: self edition. legacy setEditClub: NULL. self thingToDo. "legacy endorse: (CurrentAuthor fluidGet with: #revised)." myHistory _ self revisions with: myRevisionCount integer with: (gm carrier: legacy)]. ]]]! {void} removeLastRevisionWatcher "Inform the work that its last revision watcher is gone." myRevisionWatchers := NULL! {void} removeRevisionWatcher: work {FeWork} "Remove a previously added RevisionWatcher" myRevisionWatchers == NULL ifTrue: [Heaper BLAST: #NeverAddedRevisionWatcher]. myRevisionWatchers remove: work. myRevisionWatchers isEmpty ifTrue: [myRevisionWatchers := NULL].! {void} revise: edition {FeEdition} "Change the current edition and notify anyone who cares about the revision" DiskManager consistent: [self knownBug. "this may not be the right thing to do when not grabbed - it only happens during booting anyway" self fetchLockingWork == NULL ifTrue: [myReviser := CurrentAuthor fluidGet] ifFalse: [myReviser _ self fetchLockingWork getAuthor]. myEdition removeWork: self. myEdition := edition beEdition. myEditionLabel _ edition label getOrMakeBe cast: BeLabel. myEdition introduceWork: self. myRevisionCount _ myRevisionCount + 1. myRevisionTime := BeGrandMap xuTime. "Trigger immediate revisionDetectors" myRevisionWatchers ~~ NULL ifTrue: [myRevisionWatchers stepper forEach: [ :work {FeWork} | work triggerRevisionDetectors: edition with: myReviser with: myRevisionTime with: myRevisionCount]]. "Record result into the trail" myHistoryClub ~~ NULL ifTrue: [self recordHistory]. self diskUpdate]! {BeEdition} revisions "If there isn't already a shared Trail on this Work, create a new one. Return it" myHistory == NULL ifTrue: [DiskManager consistent: [myHistory _ CurrentGrandMap fluidGet newEmptyEdition: IntegerSpace make. self diskUpdate]]. ^myHistory! ! !BeWork methodsFor: 'permissions'! {ID | NULL} fetchEditClub "The edit Club, or NULL if there is none" ^myEditClub! {ID | NULL} fetchHistoryClub "The history Club, or NULL if there is none" ^myHistoryClub! {ID | NULL} fetchReadClub "The read Club, or NULL if there is none" ^myReadClub! {void} setEditClub: club {ID | NULL} "Change the edit Club (or remove it if NULL)." DiskManager consistent: 1 with: [myEditClub := club. self knownBug. "props" self diskUpdate]. self updateFeStatus.! {void} setHistoryClub: club {ID | NULL} "Change the history Club (or remove it if NULL)." DiskManager consistent: [| oldClub {ID | NULL} | oldClub _ myHistoryClub. myHistoryClub := club. self knownBug. "What happens when you change the club." (oldClub == NULL and: [myHistoryClub ~~ NULL]) ifTrue: [self recordHistory]. self diskUpdate].! {void} setReadClub: club {ID | NULL} "Change the read Club (or remove it if NULL)." DiskManager consistent: [myReadClub := club. self knownBug. "props" self diskUpdate]. self updateFeStatus.! ! !BeWork methodsFor: 'props'! {void} endorse: endorsements {CrossRegion} "Adds to the endorsements on this Work. The set of endorsements must be a finite number of (club ID, token ID) pairs. This requires the authority of all of the Clubs used to endorse. The token IDs must not be named IDs." endorsements isEmpty ifTrue: [^VOID]. DiskManager consistent: 8 with: [self propChange: PropChange endorsementsChange with: (BertProp endorsementsProp: (endorsements unionWith: myOwnProp endorsements))]! {CrossRegion} endorsements "All endorsements which have been placed on this Work. The Edition::transclusions () operation will be able to find the current Edition of this Work by filtering for these endorsements; they are also used to filter various other operations which directly return sets of Works." ^myOwnProp endorsements cast: CrossRegion! {BertProp} localProp ^myOwnProp! {BertProp} prop ^myOwnProp! {void} propChange: change {PropChange} with: nw {Prop} | old {Prop} | old _ myOwnProp. (change areEqualProps: old with: nw) not ifTrue: [myOwnProp _ (change changed: old with: nw) cast: BertProp. self diskUpdate. myEdition propChanged: change with: old with: nw with: (change fetchFinder: old with: nw with: self with: NULL)]! {void} retract: endorsements {CrossRegion} "Removes endorsements from this Work. This requires the authority of all of the Clubs whose endorsements are in the list. Ignores all endorsements which you could have removed, but which don't happen to be there right now." endorsements isEmpty ifTrue: [^VOID]. DiskManager consistent: 5 with: [self propChange: PropChange endorsementsChange with: (BertProp endorsementsProp: (myOwnProp endorsements minus: endorsements))]! ! !BeWork methodsFor: 'accessing'! {BooleanVar} isPurgeable ^super isPurgeable and: [self fetchLockingWork == NULL and: [myRevisionWatchers == NULL]]! {FeRangeElement} makeFe: label {BeLabel | NULL} ^FeWork on: self! {void} sponsor: clubs {IDRegion} "Add new sponsors to the Work, and notify the Clubs" | newClubs {IDRegion} | newClubs := (clubs minus: mySponsors) cast: IDRegion. newClubs isEmpty ifFalse: [DiskManager consistent: newClubs count + 1 with: [newClubs stepper forEach: [ :clubID {ID} | (CurrentGrandMap fluidGet getClub: clubID) addSponsored: self]. mySponsors := (mySponsors unionWith: newClubs) cast: IDRegion. self diskUpdate]]! {IDRegion} sponsors ^mySponsors! {void} unsponsor: clubs {IDRegion} "Remove sponsors from the Work, and notify the Clubs" | lostClubs {IDRegion} | self thingToDo. "Remove unsponsored clubs from the grandmap." self thingToDo. "When Clubs can have multiple IDs, then it might still be in the set" lostClubs := (clubs intersect: mySponsors) cast: IDRegion. lostClubs isEmpty ifFalse: [DiskManager consistent: lostClubs count + 1 with: [lostClubs stepper forEach: [ :clubID {ID} | (CurrentGrandMap fluidGet getClub: clubID) removeSponsored: self]. mySponsors := (mySponsors minus: clubs) cast: IDRegion. self diskUpdate]]! ! !BeWork methodsFor: 'private:'! {void} updateFeStatus "Tell all the FeWorks on this one to update their status" [PrimSet] USES. self feRangeElements stepper forEach: [ :work {FeWork} | work updateStatus]! ! !BeWork methodsFor: 'hooks:'! {void RECEIVE.HOOK} restartWork: rcvr {Rcvr unused} myLockingWork _ WeakPtrArray make: (BeWorkLockExecutor make: self) with: 1. myRevisionWatchers _ NULL! ! !BeWork methodsFor: 'smalltalk: passe'! {void} addSponsors: clubs {IDRegion} self passe "sponsor"! {void} removeSponsors: clubs {IDRegion} self passe! {void} unendorse: endorsements {CrossRegion} self passe! ! !BeWork methodsFor: 'creation'! create: contents {FeEdition} with: isClub {BooleanVar} | permissions {XnRegion} | super create. myEdition := contents beEdition. myEditionLabel _ contents label getOrMakeBe cast: BeLabel. myReadClub := InitialReadClub fluidFetch. myReadClub == NULL ifTrue: [permissions := CurrentGrandMap fluidGet globalIDSpace emptyRegion] ifFalse: [permissions := myReadClub asRegion]. myEditClub := InitialEditClub fluidFetch. myEditClub ~~ NULL ifTrue: [permissions := permissions with: myEditClub]. myOwnProp := BertProp permissionsProp: permissions. myRevisionCount _ IntegerVarZero. myRevisionTime _ Time xuTime. myReviser _ CurrentAuthor fluidGet. myHistory _ NULL. myHistoryClub _ NULL. self knownBug. "Should public shut off sponsorship?" InitialSponsor fluidGet == CurrentGrandMap fluidGet emptyClubID ifTrue: [mySponsors := IDSpace global emptyRegion cast: IDRegion] ifFalse: [mySponsors := InitialSponsor fluidFetch asRegion cast: IDRegion]. self restartWork: NULL. myEdition introduceWork: self. self knownBug. "Is the above all right?" isClub ifFalse: [self finishCreation.]! {void} finishCreation "Gets called once the object is created, to finish up" mySponsors stepper forEach: [ :iD {ID} | (CurrentGrandMap fluidGet getClub: iD) addSponsored: self]. self newShepherd.! ! !BeWork methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '(' << (CurrentGrandMap fluidGet iDsOf: self) << ')'! ! !BeWork methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myEdition _ receiver receiveHeaper. myEditionLabel _ receiver receiveHeaper. myReadClub _ receiver receiveHeaper. myEditClub _ receiver receiveHeaper. myOwnProp _ receiver receiveHeaper. myHistory _ receiver receiveHeaper. myHistoryClub _ receiver receiveHeaper. myRevisionCount _ receiver receiveIntegerVar. myRevisionTime _ receiver receiveIntegerVar. myReviser _ receiver receiveHeaper. mySponsors _ receiver receiveHeaper. self restartWork: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myEdition. xmtr sendHeaper: myEditionLabel. xmtr sendHeaper: myReadClub. xmtr sendHeaper: myEditClub. xmtr sendHeaper: myOwnProp. xmtr sendHeaper: myHistory. xmtr sendHeaper: myHistoryClub. xmtr sendIntegerVar: myRevisionCount. xmtr sendIntegerVar: myRevisionTime. xmtr sendHeaper: myReviser. xmtr sendHeaper: mySponsors.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BeWork class instanceVariableNames: ''! (BeWork getOrMakeCxxClassDescription) friends: '/* friends for class BeWork */ friend class BeWorkLockExecutor;'; attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !BeWork class methodsFor: 'creation'! make: edition {FeEdition} DiskManager consistent: [^self create: edition with: false]! !BeWork subclass: #BeClub instanceVariableNames: ' mySignatureClub {ID | NULL} myMembers {MuSet of: BeClub} myImmediateSuperClubs {MuSet of: BeClub} mySponsored {MuSet of: BeWork} myWallFlag {BooleanVar} myTransitiveSuperClubIDs {IDRegion} myTransitiveMemberIDs {IDRegion} myKeyMasters {MuSet NOCOPY | NULL of: NuKeyMaster}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Basic'! (BeClub getOrMakeCxxClassDescription) friends: '/* friends for class BeClub */ friend class UpdateTransitiveMemberIDs; friend class UpdateTransitiveSuperClubIDs; friend class UpdateClubKeyMasterAuthorities; '; attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !BeClub methodsFor: 'dependents'! {void} registerKeyMaster: km {FeKeyMaster} "Notify the KeyMaster when the transitive super Clubs of this Club change" myKeyMasters == NULL ifTrue: [myKeyMasters := MuSet make. ActiveClubs fluidGet introduce: self]. myKeyMasters introduce: km! {void} unregisterKeyMaster: km {FeKeyMaster} "Unregister a previously registered KeyMaster" myKeyMasters == NULL ifTrue: [Heaper BLAST: #NeverRegisteredKeyMaster]. myKeyMasters remove: km. myKeyMasters isEmpty ifTrue: [myKeyMasters := NULL. ActiveClubs fluidGet remove: self]! ! !BeClub methodsFor: 'accessing'! {void} addSponsored: work {BeWork} "Add a sponsored Work (sent from the Work)" DiskManager insistent: 1 with: [mySponsored store: work. self diskUpdate]! {ID | NULL} fetchSignatureClub "The Club who can endorse and sponsor with this Club" ^mySignatureClub! {BooleanVar} isPurgeable ^super isPurgeable and: [myKeyMasters == NULL]! {FeRangeElement} makeFe: label {BeLabel | NULL} ^FeClub on: self! {BooleanVar} membershipIncludes: club {BeClub} "Whether the direct membership includes the given Club" ^myMembers hasMember: club! {void} removeSponsored: work {BeWork} "Add a sponsored Work (sent from the Work)" DiskManager insistent: 1 with: [mySponsored wipe: work. self diskUpdate]! {void} setSignatureClub: clubID {ID | NULL} "Change the Club who can endorse and sponsor with this Club" mySignatureClub := clubID! {ImmuSet of: BeWork} sponsored ^mySponsored asImmuSet! {IDRegion} transitiveMemberIDs ^myTransitiveMemberIDs! {IDRegion} transitiveSuperClubIDs ^myTransitiveSuperClubIDs! ! !BeClub methodsFor: 'private: propagating'! {void} updateKeyMasters myKeyMasters ~~ NULL ifTrue: ["notify any KeyMasters who care that my transitive super clubs have changed" myKeyMasters stepper forEach: [ :km {FeKeyMaster} | km updateAuthority]]! ! !BeClub methodsFor: 'private: accessing'! {MuSet of: BeClub} immediateSuperClubs ^ myImmediateSuperClubs! {MuSet of: BeClub} members ^ myMembers! ! !BeClub methodsFor: 'contents'! {void} revise: contents {FeEdition} "Update cached information" | oldMembers {MuSet of: BeClub} oldMembership {FeEdition} newMembership {FeEdition} memberTest {BooleanVar} | (FeClubDescription check: contents) ifFalse: [Heaper BLAST: #MustBeClubDescription]. DiskManager consistent: [oldMembership := (self edition fetch: (Sequence string: 'ClubDescription:Membership')) cast: FeEdition. super revise: contents. "Do this first so that permissions will change after the revision" newMembership := (contents fetch: (Sequence string: 'ClubDescription:Membership')) cast: FeEdition. "Update cached info if membership changes" (oldMembership == NULL or: [oldMembership isEmpty]) ifTrue: [memberTest _ newMembership == NULL or: [newMembership isEmpty]] ifFalse: [memberTest _ newMembership ~~ NULL and: [newMembership isIdentical: oldMembership]]. memberTest ifFalse: [oldMembers := myMembers. myMembers := MuSet make. newMembership stepper forEach: [ :mem {FeWork} | myMembers introduce: (mem getOrMakeBe cast: BeClub)]. "Update all new members" (myMembers asImmuSet minus: oldMembers) stepper forEach: [ :newMem {BeClub} | newMem addImmediateSuperClub: self]. "Update all lost members" (oldMembers asImmuSet minus: myMembers) stepper forEach: [ :lostMem {BeClub} | lostMem removeImmediateSuperClub: self]. "Update self and all parents with new membership list" self updateTransitiveMemberIDs. self diskUpdate]]! ! !BeClub methodsFor: 'propagating'! {void} addImmediateSuperClub: parent {BeClub} "Add an immediate super Club and update my cached information, and those of my members" myImmediateSuperClubs store: parent. self updateTransitiveSuperClubIDs.! {void} removeImmediateSuperClub: parent {BeClub} "Add an immediate super Club and update my cached information, and those of my members" myImmediateSuperClubs remove: parent. self updateTransitiveSuperClubIDs.! {void} updateTransitiveMemberIDs "Figure out result of changes in membership, then propagate upwards" | result {XnRegion} | result := IDSpace global emptyRegion. myMembers stepper forEach: [ :mem {BeClub} | result := (result unionWith: mem transitiveMemberIDs)]. result := (result with: (CurrentGrandMap fluidGet iDOf: self)). (result isEqual: myTransitiveMemberIDs) ifFalse: [DiskManager insistent: 4 with: [myTransitiveMemberIDs := result cast: IDRegion. self diskUpdate. myImmediateSuperClubs isEmpty ifFalse: [(UpdateTransitiveMemberIDs make: myImmediateSuperClubs copy asMuSet) schedule]]]! {void} updateTransitiveSuperClubIDs "Figure out result of changes in membership, then propagate upwards" | result {XnRegion} | result := IDSpace global emptyRegion. myImmediateSuperClubs stepper forEach: [ :sup {BeClub} | result := (result unionWith: sup transitiveSuperClubIDs)]. result := (result with: (CurrentGrandMap fluidGet iDOf: self)). (result isEqual: myTransitiveSuperClubIDs) ifFalse: [DiskManager insistent: 4 with: [myTransitiveSuperClubIDs := result cast: IDRegion. self diskUpdate. myMembers isEmpty ifFalse: [(UpdateTransitiveSuperClubIDs make: myMembers copy asMuSet with: CurrentGrandMap fluidGet) schedule]]. "notify any KeyMasters who care that my transitive super clubs have changed" myKeyMasters ~~ NULL ifTrue: [myKeyMasters stepper forEach: [ :km {FeKeyMaster} | km updateAuthority]]]! ! !BeClub methodsFor: 'hooks:'! {void RECEIVE.HOOK} restartClub: rcvr {Rcvr} myKeyMasters _ NULL! ! !BeClub methodsFor: 'creation'! create: contents {FeEdition} | membership {FeEdition} | super create: contents with: true. mySignatureClub := InitialOwner fluidGet. myMembers := MuSet make. membership := (contents fetch: (Sequence string: 'ClubDescription:Membership')) cast: FeEdition. membership ~~ NULL ifTrue: [membership stepper forEach: [ :club {FeClub} | myMembers introduce: club beClub]]. myImmediateSuperClubs := MuSet make. mySponsored := MuSet make. self knownBug. "wall flag" myWallFlag := false. myTransitiveSuperClubIDs := IDSpace global emptyRegion cast: IDRegion. myTransitiveMemberIDs := IDSpace global emptyRegion cast: IDRegion. myMembers stepper forEach: [ :mem {BeClub} | myTransitiveMemberIDs := (myTransitiveMemberIDs unionWith: mem transitiveMemberIDs) cast: IDRegion]. self restartClub: NULL. self finishCreation.! ! !BeClub methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. mySignatureClub _ receiver receiveHeaper. myMembers _ receiver receiveHeaper. myImmediateSuperClubs _ receiver receiveHeaper. mySponsored _ receiver receiveHeaper. myWallFlag _ receiver receiveBooleanVar. myTransitiveSuperClubIDs _ receiver receiveHeaper. myTransitiveMemberIDs _ receiver receiveHeaper. self restartClub: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: mySignatureClub. xmtr sendHeaper: myMembers. xmtr sendHeaper: myImmediateSuperClubs. xmtr sendHeaper: mySponsored. xmtr sendBooleanVar: myWallFlag. xmtr sendHeaper: myTransitiveSuperClubIDs. xmtr sendHeaper: myTransitiveMemberIDs.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BeClub class instanceVariableNames: ''! (BeClub getOrMakeCxxClassDescription) friends: '/* friends for class BeClub */ friend class UpdateTransitiveMemberIDs; friend class UpdateTransitiveSuperClubIDs; friend class UpdateClubKeyMasterAuthorities; '; attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !BeClub class methodsFor: 'smalltalk: init'! staticTimeNonInherited BeClub defineFluid: #CurrentOwner with: ServerChunk emulsion with: [NULL]. MuSet defineFluid: #ActiveClubs with: DiskManager emulsion with: [MuSet make]! ! !BeClub class methodsFor: 'creation'! make: contents {FeEdition} DiskManager consistent: [^BeClub create: contents]! !Abraham subclass: #BranchDescription instanceVariableNames: ' lastPosition {UInt32} myLeft {BranchDescription} myRight {BranchDescription} fulltrace {DagWood}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Traces'! BranchDescription comment: 'Instances of subclasses describe the different kinds of paths in a traceDag. The three kinds are root (no parent), tree (one parent) and dag (two parent) branches. The dag caching routine chases up the dag finding the max of all paths. The special case of chasing up the hierarchy is probably not worth the code. At the moment, these never go away!!!!!!'! (BranchDescription getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #DEFERRED.LOCKED; yourself)! !BranchDescription methodsFor: 'testing'! {UInt32} contentsHash ^((super contentsHash bitXor: myLeft hashForEqual) bitXor: myRight hashForEqual) bitXor: fulltrace hashForEqual! {BooleanVar} does: position {UInt32} include: tracePos {TracePosition} | mark {IntegerVar} | [PrimIndexTable] USES. mark _ (fulltrace cacheTracePos: tracePos) fetch: self. ^mark ~~ NULL and: [(Integer IntegerVar: position) <= mark]! ! !BranchDescription methodsFor: 'deferred accessing'! {void} cacheRecur: navCache {PrimIndexTable} "recur toward the root filling in the cache." self subclassResponsibility! ! !BranchDescription methodsFor: 'accessing'! {void} addSuccessorsTo: set {MuSet} "Add the first useable positions for all successor branches to the set." set store: (TracePosition make: self with: 3). myLeft ~~ NULL ifTrue: [myLeft addSuccessorsTo: set]. myRight ~~ NULL ifTrue: [myRight addSuccessorsTo: set]! {ImmuSet} successorsOf: trace {BoundedTrace} | set {MuSet} | set _ fulltrace successorsOf: trace. trace position ~~ lastPosition ifTrue: [set store: (TracePosition make: self with: trace position + 1)]. ^set asImmuSet! ! !BranchDescription methodsFor: 'position making'! {TracePosition} createAfter: trace {BoundedTrace} "Return a new successor to the receiver. The first successor is on the same branch with a higher position. Further successors are allocated in a binary-tree fashion along a new branch." lastPosition == trace position ifTrue: [^self nextPosition] ifFalse: [| branch {BranchDescription} | branch _ BranchDescription make: fulltrace with: trace. fulltrace installBranch: branch after: trace. ^branch nextPosition]! {void} installBranch: branch {BranchDescription} "Install branch as a descendant branch of myself. Walk down the binary tree of branches to find a place to lodge it. This gets called if there was already a branch existing off my root." (branch isEqual: self) ifTrue: [^VOID]. self diskUpdate. myLeft == NULL ifTrue: [myLeft _ branch] ifFalse: [| tmpBr {BranchDescription} | myLeft installBranch: branch. tmpBr _ myLeft. myLeft _ myRight. myRight _ tmpBr]! {void} installBranch: branch {BranchDescription} after: trace {TracePosition} fulltrace installBranch: branch after: trace! {BranchDescription} makeBranch: trace1 {TracePosition} with: trace2 {TracePosition} "Create a dag branch that succeeds both trace1 and trace2." ^BranchDescription make: fulltrace with: trace1 with: trace2! {TracePosition} nextPosition "Return the first available tracePosition on this branch." lastPosition _ lastPosition + 1. self diskUpdate. ^TracePosition make: self with: lastPosition! ! !BranchDescription methodsFor: 'protected: protected create'! create: ft {DagWood} super create. fulltrace _ ft. myLeft _ NULL. myRight _ NULL. lastPosition _ 2! ! !BranchDescription methodsFor: 'printing'! {void} printOn: aStream {ostream reference} aStream << self hashForEqual! ! !BranchDescription methodsFor: 'smalltalk: smalltalk passe'! {Boolean} = another {BranchDescription} self passe! {UInt32} ohashForEqual "See the comment for isEqual:." "^myBranchNum * 945737"! {BooleanVar} oisEqual: another {Heaper} "^(another isKindOf: BranchDescription) and: [(another basicCast: BranchDescription) branchNum == myBranchNum]"! ! !BranchDescription methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. lastPosition _ receiver receiveUInt32. myLeft _ receiver receiveHeaper. myRight _ receiver receiveHeaper. fulltrace _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendUInt32: lastPosition. xmtr sendHeaper: myLeft. xmtr sendHeaper: myRight. xmtr sendHeaper: fulltrace.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BranchDescription class instanceVariableNames: ''! (BranchDescription getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #DEFERRED.LOCKED; yourself)! !BranchDescription class methodsFor: 'instance creation'! make: fulltrace {DagWood} ^RootBranch create: fulltrace! make: fulltrace {DagWood} with: parent {TracePosition} ^TreeBranch create: fulltrace with: parent! {BranchDescription} make: fulltrace {DagWood} with: parent1 {TracePosition} with: parent2 {TracePosition} ^DagBranch create: fulltrace with: parent1 with: parent2! !BranchDescription subclass: #DagBranch instanceVariableNames: ' parent1 {TracePosition} parent2 {TracePosition}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Traces'! (DagBranch getOrMakeCxxClassDescription) attributes: ((Set new) add: #COPY; add: #SHEPHERD.ANCESTOR; add: #LOCKED; add: #NOT.A.TYPE; add: #CONCRETE; yourself)! !DagBranch methodsFor: 'caching'! {void} cacheRecur: navCache {PrimIndexTable} parent1 cacheIn: navCache. parent2 cacheIn: navCache! ! !DagBranch methodsFor: 'create'! create: ft {DagWood}with: p1 {TracePosition} with: p2 {TracePosition} super create: ft. parent1 _ p1. parent2 _ p2. self newShepherd. self remember! ! !DagBranch methodsFor: 'testing'! {UInt32} contentsHash ^(super contentsHash bitXor: parent1 hashForEqual) bitXor: parent2 hashForEqual! ! !DagBranch methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. parent1 _ receiver receiveHeaper. parent2 _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: parent1. xmtr sendHeaper: parent2.! !BranchDescription subclass: #RootBranch instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Traces'! (RootBranch getOrMakeCxxClassDescription) attributes: ((Set new) add: #COPY; add: #SHEPHERD.ANCESTOR; add: #LOCKED; add: #NOT.A.TYPE; add: #CONCRETE; yourself)! !RootBranch methodsFor: 'caching'! {void} cacheRecur: navCache {PrimIndexTable} "The recursion ends here."! ! !RootBranch methodsFor: 'create'! create: ft {DagWood} super create: ft. self newShepherd. self remember! ! !RootBranch methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !BranchDescription subclass: #TreeBranch instanceVariableNames: 'parent {TracePosition}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Traces'! (TreeBranch getOrMakeCxxClassDescription) attributes: ((Set new) add: #COPY; add: #SHEPHERD.ANCESTOR; add: #LOCKED; add: #NOT.A.TYPE; add: #CONCRETE; yourself)! !TreeBranch methodsFor: 'caching'! {void} cacheRecur: navCache {PrimIndexTable} parent cacheIn: navCache! ! !TreeBranch methodsFor: 'create'! create: ft {DagWood} with: p {TracePosition} super create: ft. parent _ p. self newShepherd. self remember! ! !TreeBranch methodsFor: 'testing'! {UInt32} contentsHash ^super contentsHash bitXor: parent hashForEqual! ! !TreeBranch methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. parent _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: parent.! !Abraham subclass: #CanopyCrum instanceVariableNames: ' child1 {CanopyCrum | NULL} child2 {CanopyCrum | NULL} parent {CanopyCrum | NULL} minH {IntegerVar} maxH {IntegerVar} myOwnFlags {UInt32} myFlags {UInt32} myRefCount {IntegerVar}' classVariableNames: ' FlagEndorsements {PtrArray of: Position | XnRegion} OtherClubs {IDRegion} OtherEndorsements {CrossRegion} TheEFlagsCache {Heaper2UInt32Cache} ThePFlagsCache {Heaper2UInt32Cache} ' poolDictionaries: '' category: 'Xanadu-Be-Canopy'! CanopyCrum comment: 'CanopyCrums form binary trees that acrete in a balanced fashion. No rebalancing ever happens. Things are simply added to the tree up to the point thta the tree is balanced, then the height of the tree gets extended at the root. Essentially, when the join of two trees is asked for, if the two trees aren''t already parts of a larger tree, the algorithm attempts to find a place in one tree into which the other tree could completely fit without violating the depth constraint on the tree. It then returns the nearest root that contains both trees. If it can''t put one tree into the other, then it makes a new node that joins the two trees (probably with room to add other stuff deeper down). myRefCount is only the count of Loafs or HCrums that point at the CanopyCrum. It doesn''t include other CanopyCrums. 12/2/92 Ravi PropJoints have been suspended, and their function has been replaced by flag words in the CanopyCrum. Any interesting Club or endorsement gets a bit, and there is a bit for "any other Club" and "any other endorsement". Any criteria not given a bit of their own require an exhaustive search. These flags are widded by ORing up the canopy. When we start using more sophisticated hashing strategies, we will probably need to reanimate PropJoints.'! (CanopyCrum getOrMakeCxxClassDescription) friends: 'friend class RecorderHoister; '; attributes: ((Set new) add: #DEFERRED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #DEFERRED.LOCKED; yourself)! !CanopyCrum methodsFor: 'canopy operations'! {CanopyCrum} computeJoin: otherBCrum {CanopyCrum} "Find a canopyCrum that is an anscestor to both the receiver and otherBCrum. otherBCrum is added to the canopy in a pseudo-balanced fashion. This demonstrates the beauty and power of caching in object-oriented systems." | otherPath {MuSet of: CanopyCrum} myRoot {CanopyCrum} otherRoot {CanopyCrum} cache {CanopyCache} | (self isLE: otherBCrum) ifTrue: [^self]. cache _ self canopyCache. otherPath _ cache pathFor: otherBCrum. otherRoot _ cache rootFor: otherBCrum. (otherBCrum isLE: self) ifTrue: [^otherBCrum]. otherPath stepper forEach: [:bCrum {CanopyCrum} | (bCrum isLE: self) ifTrue: [^bCrum]]. myRoot _ cache rootFor: self. myRoot maxHeight > otherRoot maxHeight ifTrue: [^self makeJoin: otherRoot] ifFalse: [^otherBCrum makeJoin: myRoot]! {Pair of: CanopyCrum} expand "split into two if possible, return the two leaves" (child1 ~~ NULL and: [child2 ~~ NULL]) ifTrue: [^Pair make: self with: self]. (child1 == NULL and: [child2 == NULL]) assert: 'Must be both or niether'. DiskManager consistent: 3 with: [(child1 _ self makeNew) setParent: self. (child2 _ self makeNew) setParent: self. self canopyCache updateCache: child1 forParent: self. self canopyCache updateCache: child2 forParent: self. self diskUpdate]. ^Pair make: child1 with: child2! {void} includeCanopy: otherCanopy {CanopyCrum} "Install otherCanopy at or below the receiver. If the otherCanopy fits in a lower branch, put it there. Otherwise, replace the shortest child with a new child that contains the shortest child and otherCanopy." "This should be a friend or private function or something." | | self thingToDo. "Propagate the children's props into their new parent" self thingToDo. "When we have non-props to propagate, do those, too. i.e., height is currently handle by changeCanopy and will be moved out to HeightChanger momentarily." child1 ~~ NULL assert: 'shouldnt get here.'. child1 heightDiff >= otherCanopy maxHeight ifTrue: [child1 includeCanopy: otherCanopy] ifFalse: [child2 heightDiff >= otherCanopy maxHeight ifTrue: [child2 includeCanopy: otherCanopy] ifFalse: [DiskManager consistent: [child1 maxHeight > child2 maxHeight ifTrue: [(child2 _ self makeNewParent: child2 with: otherCanopy) setParent: self] ifFalse: [(child1 _ self makeNewParent: child1 with: otherCanopy) setParent: self]. "Update the cache for the newly installed subTree because of the new tree above it." self canopyCache updateCacheFor: otherCanopy. (Sequencer make: (PropChanger height: self) with: (PropChanger make: self)) schedule]]]! {Boolean} isLE: other {CanopyCrum} "Return true if other is equal to the receiver or an anscestor (through the parent links). Use caches for efficiency." ^(self canopyCache pathFor: other) hasMember: self! ! !CanopyCrum methodsFor: 'canopy accessing'! {void} addPointer: ignored {Heaper unused} "Keep a refcount of diskful pointers to myself for disk space management. (Maybe backpointers later.)" myRefCount _ myRefCount + 1. myRefCount == 1 ifTrue: [self remember]. self diskUpdate! {CanopyCrum} fetchParent ^parent! {UInt32} flags ^myFlags! {IntegerVar} heightDiff ^maxH - minH! {BooleanVar} isLeaf ^child1 == NULL and: [child2 == NULL]! {IntegerVar}maxHeight ^maxH! {IntegerVar}minHeight ^minH! {void} removePointer: ignored {Heaper unused} "Keep a refcount of diskful pointers to myself for disk space management. (Maybe backpointers later.) Forget the object if it goes to zero." self thingToDo. "Is calling destroy a bug?" myRefCount _ myRefCount - 1. MarkM knownBug. "refCunt going to 0 with an outstanding AgendaItem." "(myRefCount == IntegerVar0 and: [parent == NULL]) ifTrue: [self forget; destroy] ifFalse: ["self diskUpdate! {void} setParent: p {CanopyCrum | NULL} (parent == NULL and: [p ~~ NULL]) ifTrue: [self remember]. parent _ p. (myRefCount == IntegerVar0 and: [parent == NULL]) ifTrue: [self destroy] ifFalse: [self diskUpdate]! ! !CanopyCrum methodsFor: 'protected:'! {CanopyCache wimpy} canopyCache self subclassResponsibility! {void} dismantle parent == NULL assert: 'We can only dismantle the canopy from the root on up.'. self thingToDo. "This first needs to remove all of myOwnProps from the canopy." DiskManager consistent: 3 with: [child1 ~~ NULL ifTrue: [child1 setParent: NULL. child1 _ NULL]. child2 ~~ NULL ifTrue: [child2 setParent: NULL. child2 _ NULL]. super dismantle]! {CanopyCrum} fetchChild1 ^child1! {CanopyCrum} fetchChild2 ^child2! {CanopyCrum} makeNew self subclassResponsibility! {UInt32} ownFlags ^myOwnFlags! {void} setOwnFlags: newFlags {UInt32} myOwnFlags _ newFlags.! ! !CanopyCrum methodsFor: 'create'! create: flags {UInt32} "Make a canopyCrum for a root: it has no children." super create. minH _ maxH _ 1. child1 _ child2 _ parent _ NULL. myOwnFlags _ flags. myFlags _ myOwnFlags. myRefCount _ IntegerVar0! create: flags {UInt32} with: first {CanopyCrum} with: second {CanopyCrum} "prop must be empty" super create. "prop isEmpty assert: 'Must be empty'." minH _ maxH _ 1. child1 _ first. child1 setParent: self. child2 _ second. child2 setParent: self. parent _ NULL. myOwnFlags _ flags. myFlags _ (flags bitOr: child1 flags) bitOr: child2 flags. myRefCount _ IntegerVar0! ! !CanopyCrum methodsFor: 'smalltalk: verification'! {CanopyCrum} another "Return another instance of the same class for testing purposes." ^CanopyCrum create! {IntegerVar} refCount ^myRefCount! {CanopyCrum} verify1 "BertCrum create verify1" 50 timesRepeat: [self computeJoin: self another]. ^self! {CanopyCrum} verify2 "BertCrum create verify2." self verifyHeight: 5. self computeJoin: (self another verifyHeight: 3). ^self! {CanopyCrum} verifyHeight: height {IntegerVar} "Create a tree with maxHeight = height and minHeight = 2." "BertCrum create verifyHeight: 4." (2 raisedTo: height - 2) timesRepeat: [self computeJoin: self another]. ^self! ! !CanopyCrum methodsFor: 'smalltalk:'! {Array of: CanopyCrum} childArray ^child1 == NULL ifTrue: [#()] ifFalse: [child2 == NULL ifTrue: [Array with: child1] ifFalse: [Array with: child1 with: child2]]! {Array of: CanopyCrum} children ^child1 == NULL ifTrue: [#()] ifFalse: [child2 == NULL ifTrue: [Array with: child1] ifFalse: [Array with: child1 with: child2]]! displayString ^String streamContents: [:aStream | aStream print: maxH. maxH = minH ifFalse: [aStream nextPut: $-; print: minH]]! inspect Sensor leftShiftDown ifTrue: [self basicInspect] ifFalse: [| cur {CanopyCrum} | cur _ self. [cur fetchParent == NULL] whileFalse: [cur _ cur fetchParent]. cur inspectSubCanopy: self]! inspectSubCanopy: start EntView openOn: (TreeBarnacle new buildOn: self gettingChildren: [:crum | crum childArray] gettingImage: [:crum | crum = start ifTrue: [crum displayString asText allBold asDisplayText] ifFalse: [crum displayString asDisplayText]] at: 0 @ 0 vertical: true separation: 5 @ 10)! ! !CanopyCrum methodsFor: 'props'! {AgendaItem} propChanger: change {PropChange unused} with: prop {Prop} "Return an AgendaItem to propagate properties. NOTE: The AgendaItem returned is not yet scheduled. Doing so is up to my caller." | | "Atomically Update myOwnFlags but not myFlags (The latter includes the widded stuff) return a PropChanger which at each step will update myPropJoint and move to parent." DiskManager insistent: 3 with: [myOwnFlags _ myOwnFlags bitOr: prop flags. self diskUpdate. ^PropChanger make: self]! ! !CanopyCrum methodsFor: 'testing'! {UInt32} contentsHash "This is only used by the TestPacker, so it includes all persistent state whether or not it is semantically interesting--myRefCount is not semantically interesting." ^(((((((super contentsHash bitXor: child1 hashForEqual) bitXor: child2 hashForEqual) bitXor: parent hashForEqual) bitXor: (IntegerPos integerHash: minH)) bitXor: (IntegerPos integerHash: maxH)) bitXor: myFlags) bitXor: myOwnFlags) bitXor: (IntegerPos integerHash: myRefCount)! ! !CanopyCrum methodsFor: 'protected'! {BooleanVar} changeCanopy "Figure out new props, etc. Return true if any changes may require further propagation" "At least one subclass adds behavior here by overriding and calling 'super changeCanopy:'" | result {BooleanVar} | "If this is a leaf If any of my properties are changed Store the modification of the props. else save current flags recalculate the flags from myOwnFlags and the flags of the children If anything changed flag that the change must be written to disk return whether anything changed (which requires propagation rootward)" self isLeaf ifTrue: [result := myFlags ~= myOwnFlags. myFlags := myOwnFlags] ifFalse: [ | before {UInt32} | before := myFlags. myFlags := (myOwnFlags bitOr: child1 flags) bitOr: child2 flags. result := before ~= myFlags]. result ifTrue: [self diskUpdate]. ^result! {BooleanVar} changeHeight "Figure out new height. Return true if changes may require further propagation" | oldMin {IntegerVar} oldMax {IntegerVar} | "If this is a leaf then it cannot have changed otherwise, recalculate the heights from the heights of the children If anything changed flag that the change must be written to disk return whether anything changed (which requires propagation rootward)" self isLeaf ifTrue: [^false]. oldMin := minH. oldMax := maxH. child1 minHeight > child2 minHeight ifTrue: [minH := child2 minHeight + 1] ifFalse: [minH := child1 minHeight + 1]. child1 maxHeight > child2 maxHeight ifTrue: [maxH := child1 maxHeight + 1] ifFalse: [maxH := child2 maxHeight + 1]. (oldMin ~= minH or: [oldMax ~= maxH]) ifTrue: [self diskUpdate. ^true] ifFalse: [^false]! {CanopyCrum} makeNewParent: first {CanopyCrum} with: second {CanopyCrum} "Make a new crum that contains both first and second. This method just makes a new parent whose properties are empty. My client must bring my properties up to date" self subclassResponsibility! ! !CanopyCrum methodsFor: 'private'! {CanopyCrum} makeJoin: otherCanopy {CanopyCrum} "Install otherCanopy as a subtree in the canopy containing the receiver. Look below the receiver and then in successively higher branches for a branch that has enough height difference to contain otherCanopy." | height {IntegerVar} cur {CanopyCrum} prev {CanopyCrum} | self thingToDo. "Propagate the children's props into their new parent" self thingToDo. "When we have non-props to propagate, do those, too. i.e., height is currently handle by changeCanopy and will be moved out to HeightChanger momentarily." height _ otherCanopy maxHeight. cur _ self. [cur == NULL or: [cur heightDiff >= height]] whileFalse: [prev _ cur. cur _ cur fetchParent]. cur == NULL ifTrue: ["join the trees at the top" cur _ self makeNewParent: prev with: otherCanopy. self canopyCache updateCache: prev forParent: cur. self canopyCache updateCache: otherCanopy forParent: cur.] ifFalse: ["found a branch that can contain otherCanopy. Place it in that branch." cur includeCanopy: otherCanopy]. "Cur now contains the closest parent shared between self and otherCanopy." ^cur! ! !CanopyCrum methodsFor: 'smalltalk: suspended'! {BooleanVar} changeCanopy: change {PropChange unused} "Figure out new height, props, etc. Return true if any changes may require further propagation" "At least one subclass adds behavior here by overriding and calling 'super changeCanopy:'" | result {BooleanVar} | "If this is a leaf If any of my properties are changed Store the modification of the props. else save current flags recalculate the flags from myOwnFlags and the flags of the children if we're changing all properties (kludge for when combining trees) recompute heights (min and max) If anything changed flag that the change must be written to disk return whether anything changed (which requires propagation rootward)" self isLeaf ifTrue: [result := myFlags ~= myOwnFlags. result ifTrue: [myFlags := myOwnFlags]] ifFalse: [ | before {UInt32} | before := myFlags. myFlags := (myOwnFlags bitOr: child1 flags) bitOr: child2 flags. change isFull ifTrue: [ | oldMin {IntegerVar} oldMax {IntegerVar} | self thingToDo. "Need to move height calculation into a different sort of PropChanger that propagates immediately." oldMin := minH. oldMax := maxH. child1 minHeight > child2 minHeight ifTrue: [minH := child2 minHeight + 1] ifFalse: [minH := child1 minHeight + 1]. child1 maxHeight > child2 maxHeight ifTrue: [maxH := child1 maxHeight + 1] ifFalse: [maxH := child2 maxHeight + 1]. result := oldMin ~= minH or: [oldMax ~= maxH]] ifFalse: [result := false]. result := result or: [before ~= myFlags]]. result ifTrue: [self diskUpdate]. ^result! {PropChange} fullChange self subclassResponsibility! {PropJoint} joint "Return the abstracted information necessary to determine whether anything leafward may pass the filtering criteria." ^myPropJoint! ! !CanopyCrum methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. child1 _ receiver receiveHeaper. child2 _ receiver receiveHeaper. parent _ receiver receiveHeaper. minH _ receiver receiveIntegerVar. maxH _ receiver receiveIntegerVar. myOwnFlags _ receiver receiveUInt32. myFlags _ receiver receiveUInt32. myRefCount _ receiver receiveIntegerVar.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: child1. xmtr sendHeaper: child2. xmtr sendHeaper: parent. xmtr sendIntegerVar: minH. xmtr sendIntegerVar: maxH. xmtr sendUInt32: myOwnFlags. xmtr sendUInt32: myFlags. xmtr sendIntegerVar: myRefCount.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CanopyCrum class instanceVariableNames: ''! (CanopyCrum getOrMakeCxxClassDescription) friends: 'friend class RecorderHoister; '; attributes: ((Set new) add: #DEFERRED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #DEFERRED.LOCKED; yourself)! !CanopyCrum class methodsFor: 'smalltalk: init'! initTimeNonInherited self REQUIRES: Heaper2UInt32Cache. TheEFlagsCache := Heaper2UInt32Cache make: 50. ThePFlagsCache := Heaper2UInt32Cache make: 50.! linkTimeNonInherited FlagEndorsements := NULL. OtherClubs := NULL. OtherEndorsements := NULL. TheEFlagsCache := NULL. ThePFlagsCache := NULL.! ! !CanopyCrum class methodsFor: 'protected: flags'! {UInt32} endorsementsFlags: endorsements {CrossRegion} "Flag bits corresponding to endorsements" | result {UInt32} f {UInt32} | result := TheEFlagsCache fetch: endorsements. (result ~= UInt32Zero or: [endorsements isEmpty]) ifTrue: [^result]. f := self firstEndorsementsFlag. FlagEndorsements ~~ NULL assert: 'Must be initialized'. UInt32Zero almostTo: FlagEndorsements count do: [ :i {UInt32} | (FlagEndorsements get: i) cast: Position into: [ :p | (endorsements hasMember: p) ifTrue: [result := result bitOr: f]] cast: XnRegion into: [ :r | (endorsements intersects: r) ifTrue: [result := result bitOr: f]]. f := f bitShift: 1]. (endorsements intersects: OtherEndorsements) ifTrue: [result := result bitOr: self otherEndorsementsFlag]. TheEFlagsCache at: endorsements cache: result. ^result! {UInt32} permissionsFlags: permissions {IDRegion} "Flag bits corresponding to permissions" | result {UInt32} | result := ThePFlagsCache fetch: permissions. result ~= UInt32Zero ifTrue: [^result]. [BeGrandMap] USES. (permissions hasMember: CurrentGrandMap fluidGet publicClubID) ifTrue: [result := result bitOr: self publicClubFlag]. OtherClubs == NULL ifTrue: [OtherClubs := CurrentGrandMap fluidGet publicClubID asRegion complement cast: IDRegion]. (permissions intersects: OtherClubs) ifTrue: [result := result bitOr: self otherClubsFlag]. ThePFlagsCache at: permissions cache: result. ^result! ! !CanopyCrum class methodsFor: 'private: flags'! {Int32} endorsementFlagLimit "Max number of special endorsement flags" ^23 "28 bits - 2 for permissions - 1 for all other endorsements - 2 reserved"! {UInt32} firstEndorsementsFlag "Rightmost flag for interesting endorsements" ^16r00000008! {UInt32} otherClubsFlag "The flag for any other Clubs" ^16r00000002! {UInt32} otherEndorsementsFlag "Flag for all uninteresting endorsements" ^16r00000004! {UInt32} publicClubFlag "The flag for the Universal Public Club" ^16r00000001! ! !CanopyCrum class methodsFor: 'flag setup'! {void} useEndorsementFlags: endorsements {PtrArray of: Position | XnRegion} "Use a special flag to look for any of the these endorsements" (FlagEndorsements == NULL or: [FlagEndorsements contentsEqual: endorsements]) ifFalse: [Heaper BLAST: #InvalidRequest]. "Tried to initialize twice" endorsements count > self endorsementFlagLimit ifTrue: [Heaper BLAST: #IndexOutOfBounds]. FlagEndorsements := endorsements copy cast: PtrArray. OtherEndorsements := CurrentGrandMap fluidGet endorsementSpace fullRegion cast: CrossRegion. Int32Zero almostTo: FlagEndorsements count do: [ :i {Int32} | (FlagEndorsements get: i) cast: Position into: [ :p | OtherEndorsements := (OtherEndorsements without: p) cast: CrossRegion] cast: XnRegion into: [ :r | OtherEndorsements := (OtherEndorsements minus: r) cast: CrossRegion]].! !CanopyCrum subclass: #BertCrum instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Canopy'! BertCrum comment: 'This implementation tracks the endorsement information with a strictly binary tree. The tree gets heuristically balanced upon insertion of new elements in such a way that the ocrums pointing at a particular canopyCrum need not be updated. Therefore we should not bother storing backpointers. I''m doing so currently in case we change algorithms. Deletion may require backpointers to eliminate joins with the deleted crums.'! (BertCrum getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !BertCrum methodsFor: 'private: creation'! create "Make a canopyCrum for a root: it has no children." super create: UInt32Zero. self newShepherd! ! !BertCrum methodsFor: 'protected:'! {CanopyCache wimpy} canopyCache "should have one per Ent" ^CurrentBertCanopyCache fluidGet! {CanopyCrum} makeNew ^BertCrum create! ! !BertCrum methodsFor: 'smalltalk:'! {CanopyCrum} another "BertCrum create verify2." ^BertCrum create! inspectHCrums | owners | owners _ self allOwners select: [ :each | each isKindOf: HistoryCrum]. owners isEmpty ifTrue: [Transcript show: 'Nobody'; cr] ifFalse: [owners size = 1 ifTrue: [owners first inspect] ifFalse: [owners inspect]]! inspectMenuArray ^#( ('inspect hcrums' inspectHCrums '') )! printOn: aStream aStream << self getCategory name << '(' << self children size << ')'. "child1 = NULL ifTrue: [aStream << (self flags printStringRadix: 2)] ifFalse: [aStream nextPut: $(; print: child1; nextPut: $,; print: child2; nextPut: $)]"! showOn: oo oo print: self maxHeight. self maxHeight == self minHeight ifFalse: [oo nextPut: $-; print: self minHeight]. oo print: (self flags printStringRadix: 2)! ! !BertCrum methodsFor: 'protected'! {CanopyCrum} makeNewParent: first {CanopyCrum} with: second {CanopyCrum} DiskManager consistent: 3 with: [^BertCrum create: (first cast: BertCrum) with: (second cast: BertCrum)]! ! !BertCrum methodsFor: 'instance creation'! create: first {BertCrum} with: second {BertCrum} "Create a new parent for two BertCrums. My client must bring my properties up to date. This constructor just makes a new parent whose properties are empty" | | "Have the super do the basic creation." super create: UInt32Zero with: first with: second. self newShepherd. self canopyCache updateCache: self fetchChild1 forParent: self. self canopyCache updateCache: self fetchChild2 forParent: self! ! !BertCrum methodsFor: 'smalltalk: suspended'! {PropChange} fullChange ^PropChange bertPropChange! ! !BertCrum methodsFor: 'accessing'! {BooleanVar} isNotPartializable ^(self flags bitAnd: BertCrum isNotPartializableFlag) ~= UInt32Zero! {BooleanVar} isSensorWaiting ^(self flags bitAnd: BertCrum isSensorWaitingFlag) ~= UInt32Zero! ! !BertCrum methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BertCrum class instanceVariableNames: ''! (BertCrum getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !BertCrum class methodsFor: 'smalltalk: initialization'! staticTimeNonInherited CanopyCache defineFluid: #CurrentBertCanopyCache with: DiskManager emulsion with: [CanopyCache make]! ! !BertCrum class methodsFor: 'instance creation'! make DiskManager consistent: 1 with: [ ^BertCrum create]! ! !BertCrum class methodsFor: 'flags'! {UInt32} flagsFor: permissions {IDRegion | NULL} with: endorsements {CrossRegion | NULL} with: isNotPartializable {BooleanVar} with: isSensorWaiting {BooleanVar} "The flag word corresponding to the given props" | result {UInt32} | result := UInt32Zero. permissions ~~ NULL ifTrue: [result := result bitOr: (CanopyCrum permissionsFlags: permissions)]. endorsements ~~ NULL ifTrue: [result := result bitOr: (CanopyCrum endorsementsFlags: endorsements)]. isNotPartializable ifTrue: [result := result bitOr: self isNotPartializableFlag]. isSensorWaiting ifTrue: [result := result bitOr: self isSensorWaitingFlag]. ^result! {UInt32 constFn} isNotPartializableFlag "Flag bit for active Editions" ^16r08000000! {UInt32 constFn} isSensorWaitingFlag "Flag bit for active Editions" ^16r04000000! !CanopyCrum subclass: #SensorCrum instanceVariableNames: 'myBackfollowRecorders {ImmuSet of: RecorderFossil}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Canopy'! SensorCrum comment: 'This implementation is the same as BertCrums. This will require pointers into the ent to implement delete (for archiving). Canopy reorganization could be achieved by removing several orgls, then re-adding them (archive then restore).'! (SensorCrum getOrMakeCxxClassDescription) friends: 'friend class RecorderHoister; '; attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !SensorCrum methodsFor: 'private: creation'! create "Make a canopyCrum for a root: it has no children." super create: UInt32Zero. myBackfollowRecorders _ ImmuSet make. self newShepherd! create: flags {UInt32} "Make a canopyCrum for a root: it has no children." super create: flags. myBackfollowRecorders _ ImmuSet make. self newShepherd! ! !SensorCrum methodsFor: 'smalltalk:'! {CanopyCrum} another "SensorCrum create verify2." ^SensorCrum create! displayString ^String streamContents: [:aStream | aStream print: self maxHeight. self maxHeight == self minHeight ifFalse: [aStream nextPut: $-; print: self minHeight]]! inspectMenuArray ^#( ('inspect oparts' inspectOParts ''))! inspectOParts | owners | owners _ self allOwners select: [ :each | each isKindOf: OPart]. owners isEmpty ifTrue: [Transcript show: 'Nobody'; cr] ifFalse: [owners size = 1 ifTrue: [owners first inspect] ifFalse: [owners inspect]]! {void} printOn: aStream [myBackfollowRecorders == nil ifTrue: [ aStream << self getCategory name << '(nil)'. ^ VOID]] smalltalkOnly. aStream << self getCategory name << '(' << (self flags printStringRadix: 2) << ')'. myBackfollowRecorders isEmpty ifFalse: [aStream << ' *']! ! !SensorCrum methodsFor: 'protected:'! {CanopyCache wimpy} canopyCache "should have one per Ent" ^CurrentSensorCanopyCache fluidGet! {CanopyCrum} makeNew Dean thingToDo. "is this right? I want to preserve the partiality flag when a partial loaf splits /ravi/5/7/92/" self isPartial ifTrue: [^SensorCrum create: SensorCrum isPartialFlag] ifFalse: [^SensorCrum create]! ! !SensorCrum methodsFor: 'accessing'! {PropFinder} checkRecorders: finder {PropFinder} with: scrum {SensorCrum | NULL} "Set off all recorders that respond to the change either in me or in any of my ancestors up to but not including sCrum (If I am the same as sCrum, skip me as well.) (If sCrum is null, search through all my ancestors to a root of the sensor canopy.) return simplest finder for looking at children" | next {SensorCrum | NULL} | "from self rootward until told to stop (at sCrum or the root) trigger any matching recorders return a simplified finder for examining children." next := self. [next ~~ NULL] whileTrue: [next := next fetchNextAfterTriggeringRecorders: finder with: scrum]. ^finder pass: self! {SensorCrum | NULL} fetchNextAfterTriggeringRecorders: finder {PropFinder} with: sCrum {SensorCrum | NULL} "Set off all recorders in me that respond to the change, if appropriate (If I am the same as sCrum, skip me.) If sCrum is null or not me, return my parent so caller can iterate through my ancestors to sCrum or a root." | | "One step of the leafward walk of the O-plane, triggering recorders: Walk rootward on the sensor canopy, where many steps may correspond to this single leafward step." "If we're the designated sCrum (where this work was already done) return without doing anything. We're done. For each of our recorders if it hasn't gone extinct reanimate it long enough to trigger it, recording stamp if finder matches. Return a pointer to our parent (so caller can iterate this operation rootward)." (sCrum ~~ NULL and: [self isEqual: sCrum]) ifTrue: [^NULL]. myBackfollowRecorders stepper forEach: [ :fossil {RecorderFossil} | fossil isExtinct ifFalse: [fossil reanimate: [:recorder {ResultRecorder} | recorder triggerIfMatching: finder with: fossil]]]. ^self fetchParent cast: SensorCrum.! {BooleanVar} isPartial ^(self flags bitAnd: SensorCrum isPartialFlag) ~= UInt32Zero! {ImmuSet of: RecorderFossil} recorders ^myBackfollowRecorders! {AgendaItem} recordingAgent: recorder {RecorderFossil} "NOTE: The AgendaItem returned is not yet scheduled. Doing so is up to my caller." | | "If the recorder we're adding isn't already present here pack up the fossil for shipment to the hoister atomically Install the recorder here return a RecorderHoister to propagate the side-effects and anneal the canopy (The RecorderHoister will update myFlags) return an empty agenda (to satisfy our contract)" (myBackfollowRecorders hasMember: recorder) ifFalse: [ | cargo {ImmuSet of: RecorderFossil} | cargo := ImmuSet make with: recorder. DiskManager consistent: 2 with: [self installRecorders: cargo. self diskUpdate. ^RecorderHoister make: self with: cargo]]. ^Agenda make! {void} removeRecorders: recorders {ImmuSet of: RecorderFossil} "Remove recorders because they have migrated rootward. Recalculate myOwnFlags and myFlags." | f {UInt32} | myBackfollowRecorders _ myBackfollowRecorders minus: recorders. self diskUpdate. f := UInt32Zero. myBackfollowRecorders stepper forEach: [ :fossil {RecorderFossil} | fossil isExtinct ifFalse: [fossil reanimate: [:recorder {ResultRecorder} | f := f bitOr: recorder sensorProp flags]]]. self setOwnFlags: f. self changeCanopy! ! !SensorCrum methodsFor: 'private:'! {void} installRecorders: recorders {ImmuSet of: RecorderFossil} "Installs the recorders in my set and updates myOwnProp accordingly. The caller has already checked that none of these recorders are already installed here. The caller also handles updating myFlags. The caller also handles all issues of rootward propagation of these changes. The caller also does the 'diskUpdate'. This is a separate method because it's called once by the code that installs a new recorder, and again by the code that recursively hoists recurders up the canopy. add the new recorders to my set for each new recorder if it hasn't gone extinct extract its properties union them into my own" myBackfollowRecorders _ myBackfollowRecorders unionWith: recorders. recorders stepper forEach: [ :fossil {RecorderFossil} | fossil isExtinct ifFalse: [ | prop {Prop} | fossil reanimate: [:recorder {ResultRecorder} | prop := recorder sensorProp]. self setOwnFlags: (self ownFlags bitOr: prop flags)]]! ! !SensorCrum methodsFor: 'protected'! {CanopyCrum} makeNewParent: first {CanopyCrum} with: second {CanopyCrum} DiskManager consistent: 3 with: [^SensorCrum create: (first cast: SensorCrum) with: (second cast: SensorCrum)]! ! !SensorCrum methodsFor: 'smalltalk: passe'! {PropFinder} checkRecorders: stamp {BeEdition} with: finder {PropFinder} with: sCrum {SensorCrum | NULL} self passe "fewer args"! {SensorCrum | NULL} fetchNextAfterTriggeringRecorders: stamp {BeEdition} with: finder {PropFinder} with: sCrum {SensorCrum | NULL} self passe "fewer args"! {void} record: recorder {RecorderFossil} self passe. "equivalent to '(self recordingAgent: recorder) schedule"! {void} triggerRecorders: stamp {Stamp} with: finder {PropFinder} with: sCrum {SensorCrum | NULL} self passe. "Use fetchNextAfterTriggeringRecorders:with:with:"! ! !SensorCrum methodsFor: 'instance creation'! create: first {SensorCrum} with: second {SensorCrum} "Create a new parent for two SensorCrums. This constructor just makes a new parent whose properties are empty. My client must bring my properties up to date." | | "Have the super do the basic creation." super create: UInt32Zero with: first with: second. self newShepherd. myBackfollowRecorders _ ImmuSet make. self canopyCache updateCache: self fetchChild1 forParent: self. self canopyCache updateCache: self fetchChild2 forParent: self! ! !SensorCrum methodsFor: 'smalltalk: suspended'! changeCanopy: f! {PropChange} fullChange ^PropChange sensorPropChange! ! !SensorCrum methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myBackfollowRecorders _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myBackfollowRecorders.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! SensorCrum class instanceVariableNames: ''! (SensorCrum getOrMakeCxxClassDescription) friends: 'friend class RecorderHoister; '; attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !SensorCrum class methodsFor: 'smalltalk: init'! staticTimeNonInherited CanopyCache defineFluid: #CurrentSensorCanopyCache with: DiskManager emulsion with: [CanopyCache make]! ! !SensorCrum class methodsFor: 'pseudo constructors'! make DiskManager consistent: 2 with: [ ^SensorCrum create]! {SensorCrum} partial DiskManager consistent: 1 with: [ ^SensorCrum create: SensorCrum isPartialFlag]! ! !SensorCrum class methodsFor: 'flags'! {UInt32} flagsFor: permissions {IDRegion | NULL} with: endorsements {CrossRegion | NULL} with: isPartial {BooleanVar} "The flag word corresponding to the given props" | result {UInt32} | result := UInt32Zero. permissions ~~ NULL ifTrue: [result := result bitOr: (CanopyCrum permissionsFlags: permissions)]. endorsements ~~ NULL ifTrue: [result := result bitOr: (CanopyCrum endorsementsFlags: endorsements)]. isPartial ifTrue: [result := result bitOr: self isPartialFlag]. ^result! {UInt32 constFn} isPartialFlag "Flag bit for existence of partiality" ^16r08000000! !Abraham subclass: #Counter instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-counter'! (Counter getOrMakeCxxClassDescription) friends: 'friend class SimpleTurtle; '; attributes: ((Set new) add: #DEFERRED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #DEFERRED.LOCKED; yourself)! !Counter methodsFor: 'accessing'! {IntegerVar} count ^self subclassResponsibility! {IntegerVar} decrement ^self subclassResponsibility! {IntegerVar} decrementBy: count {IntegerVar} ^self subclassResponsibility! {IntegerVar} increment ^self subclassResponsibility! {IntegerVar} incrementBy: count {IntegerVar} ^self subclassResponsibility! {void} setCount: count {IntegerVar} self subclassResponsibility! ! !Counter methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '(' << self count << ')'! ! !Counter methodsFor: 'protected: creation'! create super create! create: hash {UInt32} super create: hash! ! !Counter methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Counter class instanceVariableNames: ''! (Counter getOrMakeCxxClassDescription) friends: 'friend class SimpleTurtle; '; attributes: ((Set new) add: #DEFERRED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #DEFERRED.LOCKED; yourself)! !Counter class methodsFor: 'pseudo-constructors'! {Counter} fakeCounter: count {IntegerVar} with: batchCount {IntegerVar} with: hash {UInt32} ^BatchCounter makeFakeCounter: count with: batchCount with: hash! make ^SingleCounter create.! make: count {IntegerVar} ^SingleCounter create: count! make: count {IntegerVar} with: batchCount {IntegerVar} ^BatchCounter make: count with: batchCount! !Counter subclass: #BatchCounter instanceVariableNames: ' myCount {IntegerVar NOCOPY} myPersistentCount {IntegerVar} myMutex {Sema4 NOCOPY} myBatchCount {IntegerVar}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-counter'! BatchCounter comment: 'Instances preallocate a bunch of numbers and record the preallocations to disk. It then increments purely in memory until the preallocated counts are used up. It then preallocates another bunch of numbers. If the system crashes, all numbers between the in-memory count and the on-disk count simply never get used. This reduces the access to disk for shepherd hashes and GrandMap IDs.'! (BatchCounter getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !BatchCounter methodsFor: 'accessing'! {IntegerVar} count ^myCount! {IntegerVar} decrement myMutex critical: [DiskManager consistent: 1 with: [myCount _ myCount - 1. self diskUpdate]]. ^myCount! {IntegerVar} decrementBy: count {IntegerVar} count >= IntegerVarZero ifFalse: [Heaper BLAST: #InvalidRequest]. myMutex critical: [DiskManager consistent: 1 with: [myCount _ myCount - count. self diskUpdate]]. ^myCount! {IntegerVar} increment myMutex critical: [myCount _ myCount + 1. myCount > myPersistentCount ifTrue: [DiskManager consistent: 1 with: [myPersistentCount _ myCount + myBatchCount. self diskUpdate]]]. ^myCount! {IntegerVar} incrementBy: count {IntegerVar} count >= IntegerVarZero ifFalse: [Heaper BLAST: #InvalidRequest]. myMutex critical: [myCount _ myCount + count. myCount > myPersistentCount ifTrue: [DiskManager consistent: 1 with: [myPersistentCount _ myCount + myBatchCount. self diskUpdate]]]. ^myCount! {void} setCount: count {IntegerVar} myMutex critical: [DiskManager consistent: 1 with: [myCount _ count. self diskUpdate]]! ! !BatchCounter methodsFor: 'receiver: stubble'! {void RECEIVE.HOOK} restartBatchCounter: trans {Rcvr unused default: NULL} "re-initialize the non-persistent part" myCount _ myPersistentCount. myMutex _ Sema4 make: 1.! ! !BatchCounter methodsFor: 'protected: create'! create: count {IntegerVar} with: batchCount {IntegerVar} super create. DiskManager consistent: 1 with: [myPersistentCount _ myCount _ count. myBatchCount _ batchCount. self restartBatchCounter: NULL. self newShepherd. self remember]! create: count {IntegerVar} with: batchCount {IntegerVar} with: hash {UInt32} super create: hash. myPersistentCount _ myCount _ count. myBatchCount _ batchCount. self restartBatchCounter: NULL.! ! !BatchCounter methodsFor: 'testing'! {UInt32} contentsHash ^super contentsHash bitXor: (IntegerPos integerHash: myPersistentCount)! ! !BatchCounter methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myPersistentCount _ receiver receiveIntegerVar. myBatchCount _ receiver receiveIntegerVar. self restartBatchCounter: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendIntegerVar: myPersistentCount. xmtr sendIntegerVar: myBatchCount.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BatchCounter class instanceVariableNames: ''! (BatchCounter getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !BatchCounter class methodsFor: 'pseudo-constructors'! {Counter} make: count {IntegerVar} with: batchCount {IntegerVar} ^self create: count with: batchCount! {Counter} makeFakeCounter: count {IntegerVar} with: batchCount {IntegerVar} with: hash {UInt32} ^self create: count with: batchCount with: hash! !Counter subclass: #SingleCounter instanceVariableNames: ' myCount {IntegerVar} myMutex {Sema4 NOCOPY}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-counter'! SingleCounter comment: 'This counter separates a very simple state change into another flock so that big objects like GrandMaps and GrandHashTables don''t ned to flush their entirety to disk. It localizes the state change of a counter.'! (SingleCounter getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !SingleCounter methodsFor: 'accessing'! {IntegerVar} count ^myCount! {IntegerVar} decrement myMutex critical: [DiskManager consistent: 1 with: [myCount _ myCount - 1. self diskUpdate]]. ^myCount! {IntegerVar} decrementBy: count {IntegerVar} count >= IntegerVarZero ifFalse: [Heaper BLAST: #InvalidRequest]. myMutex critical: [DiskManager consistent: 1 with: [myCount _ myCount - count. self diskUpdate]]. ^myCount! {IntegerVar} increment myMutex critical: [DiskManager consistent: 1 with: [myCount _ myCount + 1. self diskUpdate]]. ^myCount! {IntegerVar} incrementBy: count {IntegerVar} count >= IntegerVarZero ifFalse: [Heaper BLAST: #InvalidRequest]. myMutex critical: [DiskManager consistent: 1 with: [myCount _ myCount + count. self diskUpdate]]. ^myCount! {void} setCount: count {IntegerVar} myMutex critical: [DiskManager consistent: 1 with: [myCount _ count. self diskUpdate]]! ! !SingleCounter methodsFor: 'receiver: restart'! {void RECEIVE.HOOK} restartSingleCounter: trans {Rcvr unused default: NULL} "re-initialize the non-persistent part" myMutex _ Sema4 make: 1.! ! !SingleCounter methodsFor: 'protected: create'! create super create. myCount _ IntegerVar0. self restartSingleCounter: NULL. self newShepherd. self remember! create: count {IntegerVar} super create. myCount _ count. self restartSingleCounter: NULL. self newShepherd. self remember! ! !SingleCounter methodsFor: 'testing'! {UInt32} contentsHash ^super contentsHash bitXor: (IntegerPos integerHash: myCount)! ! !SingleCounter methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myCount _ receiver receiveIntegerVar. self restartSingleCounter: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendIntegerVar: myCount.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! SingleCounter class instanceVariableNames: ''! (SingleCounter getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !SingleCounter class methodsFor: 'pseudo-constructors'! {Counter} make ^self create.! {Counter} make: count {IntegerVar} ^self create: count! !Abraham subclass: #DagWood instanceVariableNames: ' myRoot {TracePosition} myTrunk {MuTable of: TracePosition and: BranchDescription} myCachedPosition {TracePosition NOCOPY} myNavCache {PrimIndexTable NOCOPY}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Traces'! DagWood comment: 'Each dagwood defines a partial ordering of TracePositions. Several implementation variables use longs because they represent the size of an in-core array (which can''t get that large). The variable ''myRoot'' is just for debugging for the moment.'! (DagWood getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !DagWood methodsFor: 'accessing'! {TracePosition} root ^myRoot! {BranchDescription} successorBranchOf: branch {BranchDescription unused} position: position {UInt32 unused} "Return all the successors of the receiver in the trace tree." self unimplemented. ^NULL! {MuSet} successorsOf: trace {TracePosition} "Return the first used positions on all the successors of trace." | prevBranch {BranchDescription} set {MuSet} | set _ MuSet make. prevBranch _ (myTrunk fetch: (HeaperAsPosition make: trace)) cast: BranchDescription. prevBranch ~~ NULL ifTrue: [prevBranch addSuccessorsTo: set]. ^set! ! !DagWood methodsFor: 'branches'! {void} installBranch: branch {BranchDescription} after: anchorTrace {TracePosition} "Lookup the anchorTrace to find the branch hanging off it. If there isn't one, then install branch as that branch. Otherwise walk a balanced walk down the binary tree of branches to find a place to hang the new branch." | prevBranch {BranchDescription} pos {Position} | prevBranch _ (myTrunk fetch: (pos _ HeaperAsPosition make: anchorTrace)) cast: BranchDescription. prevBranch == NULL ifTrue: [myTrunk at: pos introduce: branch] ifFalse: [prevBranch installBranch: branch]! {TracePosition} newPosition "This should really create a new root, but that's harder to draw!!." ^myRoot newSuccessor! ! !DagWood methodsFor: 'caching'! {PrimIndexTable} cacheTracePos: tracePos {TracePosition} "Install the supplied branch and position as the navCache and return it. " (myCachedPosition ~~ NULL and: [tracePos isEqual: myCachedPosition]) ifTrue: [^myNavCache]. myCachedPosition _ tracePos. myNavCache clearAll. tracePos cacheIn: myNavCache. ^myNavCache! ! !DagWood methodsFor: 'smalltalk: inspect'! {void} inspect Sensor leftShiftDown ifTrue: [self basicInspect] ifFalse: [myRoot inspect]! ! !DagWood methodsFor: 'create'! create super create. myCachedPosition _ NULL. myNavCache _ PrimIndexTable make: 128. myTrunk _ GrandHashTable make: HeaperSpace make. myRoot _ TracePosition make: (BranchDescription make: self) with: 1. "Ensure that no elements get allocated on the root branch." myRoot newSuccessor. self newShepherd. self remember! ! !DagWood methodsFor: 'hooks:'! {void RECEIVE.HOOK} restartDagWood: trans {Rcvr unused default: NULL} "re-initialize the non-persistent part" myCachedPosition _ NULL. myNavCache _ PrimIndexTable make: 128.! ! !DagWood methodsFor: 'testing'! {UInt32} contentsHash ^super contentsHash bitXor: myRoot hashForEqual! ! !DagWood methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myRoot _ receiver receiveHeaper. myTrunk _ receiver receiveHeaper. self restartDagWood: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myRoot. xmtr sendHeaper: myTrunk.! !Abraham subclass: #DoublingFlock instanceVariableNames: 'myCount {Int32}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Snarf'! (DoublingFlock getOrMakeCxxClassDescription) attributes: ((Set new) add: #SHEPHERD.PATRIARCH; add: #COPY; add: #EQ; add: #LOCKED; add: #CONCRETE; yourself)! !DoublingFlock methodsFor: 'accessing'! {Int32} count ^myCount! {void} doDouble DiskManager consistent: 1 with: [myCount _ myCount * 2. self diskUpdate]! ! !DoublingFlock methodsFor: 'hooks:'! {void RECEIVE.HOOK} receiveTestFlock: rcvr {Rcvr} Int32Zero almostTo: myCount do: [:i {Int32} | rcvr receiveInt32 ~~ i ifTrue: [Heaper BLAST: #MustMatch]]! {void SEND.HOOK} sendTestFlock: xmtr {Xmtr} Int32Zero almostTo: myCount do: [:i {Int32} | xmtr sendInt32: i]! ! !DoublingFlock methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '(' << self hashForEqual <<', ' << myCount << ')'! ! !DoublingFlock methodsFor: 'creation'! create: hash {UInt32} super create: hash. myCount _ 1. self newShepherd! create: hash {UInt32} with: count {Int32} super create: hash. myCount _ count. self newShepherd! ! !DoublingFlock methodsFor: 'testing'! {UInt32} contentsHash ^super contentsHash bitXor: (IntegerPos integerHash: myCount)! ! !DoublingFlock methodsFor: 'generated:'! actualHashForEqual ^self asOop! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myCount _ receiver receiveInt32. self receiveTestFlock: receiver.! isEqual: other ^self == other! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendInt32: myCount. self sendTestFlock: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DoublingFlock class instanceVariableNames: ''! (DoublingFlock getOrMakeCxxClassDescription) attributes: ((Set new) add: #SHEPHERD.PATRIARCH; add: #COPY; add: #EQ; add: #LOCKED; add: #CONCRETE; yourself)! !DoublingFlock class methodsFor: 'creation'! make: hash {UInt32} ^self create: hash! make: hash {UInt32} with: count {Int32} ^self create: hash with: count! !Abraham subclass: #Ent instanceVariableNames: ' oroots {MuTable NOCOPY smalltalk of: TracePosition and: OrglRoot} fulltrace {DagWood}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Ents'! (Ent getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !Ent methodsFor: 'orgl creation'! {TracePosition} newTrace ^fulltrace newPosition! ! !Ent methodsFor: 'instance creation'! create super create. [oroots _ MuTable make: HeaperSpace make] smalltalkOnly. fulltrace _ DagWood create. self newShepherd. self remember! ! !Ent methodsFor: 'smalltalk:'! inspect Sensor leftShiftDown ifTrue: [self basicInspect] ifFalse: [self inspectFrom: fulltrace root]! inspectFrom: tracePos | seen trace | seen _ Set new. EntView openOn: (TreeBarnacle new buildOn: (self makeHandleFor: tracePos) gettingChildren: [:handle | trace _ handle tracePos. (seen includes: trace) ifTrue: [OrderedCollection new] ifFalse: [seen add: trace. trace successors asOrderedCollection collect: [:tp | self makeHandleFor: tp]]] gettingImage: [:handle | handle displayString asDisplayText] at: 0 @ 0 vertical: false separation: 10 @ 10)! {void} installORoot: root {OrglRoot} "oroots at: (HeaperAsPosition make: root hCut) store: root"! makeHandleFor: tracePos "These traceHandles are to hold a place in the ent inspection view. They are not used for ent behavior at all!!" ^RootHandle tracePos: tracePos ent: self! {OrglRoot} oRootAt: tpos {TracePosition} ^(oroots fetch: (HeaperAsPosition make: tpos)) cast: OrglRoot! ! !Ent methodsFor: 'testing'! {UInt32} contentsHash ^super contentsHash bitXor: fulltrace hashForEqual! ! !Ent methodsFor: 'smalltalk: passe'! {Pair of: TracePosition and: BertCrum} mapJoin: table {ScruTable of: (ID | ActualOrgl | IObject | PackOBits)} with: gm {BeGrandMap} "compute the join of the existing traces and bert crums in the table" "make new ones if there are none" self passe. " | n {IntegerVar} trace {TracePosition} crum {BertCrum} | [HistoryCrum] USES. n _ IntegerVar0. (table isKindOf: XnWordArray) ifFalse: [table stepper forEach: [ :each {Heaper} | | hroot {HRoot} | hroot _ NULL. (each isKindOf: ID) ifTrue: [hroot _ gm fetchIDHRoot: (each quickCast: ID)] ifFalse: [(each isKindOf: ActualOrgl) ifTrue: [hroot _ (each quickCast: ActualOrgl) stamp fetchHRoot] ifFalse: [(each isKindOf: IObject) ifTrue: [hroot _ (each quickCast: IObject) fetchHRoot]]]. hroot ~~ NULL ifTrue: [ | newtrace {TracePosition} newcrum {BertCrum} | newtrace _ hroot hCrum hCut. newcrum _ hroot hCrum bertCrum. n = IntegerVar0 ifTrue: [trace _ newtrace. crum _ newcrum] ifFalse: [trace _ trace newSuccessorAfter: newtrace. crum _ (crum computeJoin: newcrum) cast: BertCrum]. n _ n + 1]]]. n = IntegerVar0 ifTrue: [^Pair make: fulltrace newPosition with: BertCrum make]. n = 1 ifTrue: [^Pair make: trace newSuccessor with: crum]. ^Pair make: trace with: crum"! {ScruTable of: HRoot} mapTable: table {ScruTable of: (ID | ActualOrgl | IObject | PackOBits)} with: gm {BeGrandMap} "map the elements in the table to just HRoots" self passe. " | result {MuTable} stepper {TableStepper} | self passe. (table isKindOf: XnWordArray) ifTrue: [^ table]. result _ MuTable make: table coordinateSpace. (stepper _ table stepper) forEach: [ :value {Heaper} | DiskManager consistent: 11 with: [result at: stepper key store: (gm getOrMakeHRoot: value)]]. ^ result"! {OrglRoot} newOrglRoot: table {ScruTable of: FeRangeElement} with: gm {BeGrandMap} "compute the join of the existing traces and bert crums in the table" "make new ones if there are none" self passe.! {OrglRoot} newPartialOrglRoot: region {XnRegion} "create a new partial orgl root on a region" self passe. CurrentTrace fluidBind: fulltrace newPosition during: [| newCrum {BertCrum} | newCrum _ BertCrum create. CurrentBertCrum fluidBind: newCrum during: [| newRoot {OrglRoot} | newRoot _ OrglRoot make.Region: region. "oroots at: (HeaperAsPosition make: newRoot hCut) introduce: newRoot." ^newRoot]]! ! !Ent methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. fulltrace _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: fulltrace.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Ent class instanceVariableNames: ''! (Ent getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !Ent class methodsFor: 'instance creation'! {Ent} make ^ Ent create! ! !Ent class methodsFor: 'smalltalk: initialization'! staticTimeNonInherited TracePosition defineFluid: #CurrentTrace with: DiskManager emulsion with: [NULL]. BertCrum defineFluid: #CurrentBertCrum with: DiskManager emulsion with: [NULL].! ! !Ent class methodsFor: 'magic numbers'! {IntegerVar INLINE} tableSegmentMaxSize "When we are making an orgl out of a table, we break the table up into pieces which should be no larger than this, so that they each fit into a snarf." ^16384! !Abraham subclass: #GrandDataPage instanceVariableNames: ' myLowHashBits {UInt32} numEntries {Int32} entries {PtrArray of: GrandEntry} overflow {GrandOverflow} myGroup {GrandNode}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Grand'! GrandDataPage comment: 'GrandDataPage behaves as a small hash table. Linear hashing and the GrandOverflow structure are used to resolve collisions. The shift argument to the various methods is the number of pages in the parent node to indicate how many low bits of the hash are ignored.'! (GrandDataPage getOrMakeCxxClassDescription) friends: '/* friends for class GrandDataPage */ friend class GrandDataPageStepper; '; attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !GrandDataPage methodsFor: 'accessing'! {Heaper} fetch: toMatch {Heaper | Position} with: aHash {UInt32} with: shift {Int32} | localIndex {Int32} originalIndex {Int32} entry {GrandEntry} | localIndex _ originalIndex _ aHash // shift \\ numEntries. entry _ (entries fetch: localIndex) cast: GrandEntry. [entry ~~ NULL] whileTrue: [(aHash == entry hashForEqual) ifTrue: [(entry compare: toMatch) ifTrue: [^entry value]]. localIndex _ localIndex + 1 \\ numEntries. entry _ (entries fetch: localIndex) cast: GrandEntry. localIndex == originalIndex ifTrue: [ entry _ NULL "break" ]]. overflow ~~ NULL ifTrue: [ ^ overflow fetch: toMatch with: aHash]. ^NULL! {void} store.Entry: newEntry {GrandEntry} with: shift {Int32} | localIndex {UInt32} originalIndex {UInt32} entry {GrandEntry wimpy} | localIndex _ originalIndex _ newEntry hashForEqual // shift \\ numEntries. entry _ (entries fetch: localIndex) cast: GrandEntry. [entry ~~ NULL] whileTrue: [newEntry hashForEqual == entry hashForEqual ifTrue: [(newEntry matches: entry) ifTrue: ["Note that this does not delete the contents" DiskManager consistent: 1 with: [entry destroy. entries at: localIndex store: newEntry. self diskUpdate]. ^VOID]]. localIndex _ localIndex + 1 \\ numEntries. localIndex == originalIndex ifTrue: ["This page is now full" overflow == NULL ifTrue: [DiskManager consistent: 4 with: [overflow _ myGroup getOverflow store.Entry: newEntry. self diskUpdate]] ifFalse: [overflow store.Entry: newEntry]. ^VOID]. entry _ (entries fetch: localIndex) cast: GrandEntry]. "Found empty slot." DiskManager consistent: 1 with: [entries at: localIndex store: newEntry. self diskUpdate]! {void} wipe: toMatch {Heaper | Position} with: aHash {UInt32} with: shift {Int32} | localIndex {Int32} originalIndex {Int32} entry {GrandEntry wimpy} | localIndex _ originalIndex _ aHash // shift \\ numEntries. entry _ (entries fetch: localIndex) cast: GrandEntry. [entry ~~ NULL] whileTrue: [aHash == entry hashForEqual ifTrue: [(entry compare: toMatch) ifTrue: [DiskManager consistent: 2 with: [entry destroy. "Note that this does not delete the contents" entries at: localIndex store: NULL. self repack: shift. self diskUpdate]. ^VOID]]. localIndex _ localIndex + 1 \\ numEntries. entry _ (entries fetch: localIndex) cast: GrandEntry. localIndex = originalIndex ifTrue: ["break" entry _ NULL]]. overflow ~~ NULL ifTrue: [overflow wipe: toMatch with: aHash]! ! !GrandDataPage methodsFor: 'protected: creation'! create: nEntries {Int32} with: node {GrandNode} with: lowHashBits {UInt32} super create. myLowHashBits _ lowHashBits. numEntries _ nEntries. entries _ PtrArray nulls: numEntries. myGroup _ node. overflow _ NULL. self newShepherd. self remember! ! !GrandDataPage methodsFor: 'private: private'! {void} repack: shift {Int32} "This repacks the entry table after a wipe to keep the table consistent with" "the linear hash collision resolution technique." | newEntries {PtrArray of: GrandEntry} entry {GrandEntry} preferedIndex {Int32} | newEntries _ PtrArray nulls: numEntries. Int32Zero almostTo: numEntries do: [ :i {Int32} | (entry _ (entries fetch: i) cast: GrandEntry) ~~ NULL ifTrue: [preferedIndex _ entry hashForEqual // shift \\ numEntries. (newEntries fetch: preferedIndex) ~~ NULL ifTrue: [[(newEntries fetch: preferedIndex) ~~ NULL] whileTrue: [preferedIndex _ preferedIndex + 1 \\ numEntries]]. newEntries at: preferedIndex store: entry]]. entries destroy. entries _ newEntries.! ! !GrandDataPage methodsFor: 'node doubling'! {GrandDataPage} makeDouble: newNumPages {Int32} "Create a new page with all entries of current page that have a" "'1' in the new lowest significant bit of the hash." "Retain all '0' entries in this page." | newPage {GrandDataPage} oldEntry {GrandEntry wimpy} oldNumPages {Int32} | DiskManager consistent: 2 with: [oldNumPages _ newNumPages / 2. newPage _ GrandDataPage make: numEntries with: myGroup with: myLowHashBits + oldNumPages. overflow _ NULL. "Reset overflow structure. Old one is held by parent node." Int32Zero almostTo: numEntries do: [:i {Int32} | oldEntry _ (entries fetch: i) cast: GrandEntry. "This test is necessary since page to be doubled may not be full." oldEntry ~~ NULL ifTrue: [(oldEntry hashForEqual // oldNumPages bitAnd: 1) == 1 ifTrue: [newPage store.Entry: oldEntry with: newNumPages. entries at: i store: NULL]]]. "Now let pages sort themselves out." self repack: newNumPages. self diskUpdate]. ^newPage! ! !GrandDataPage methodsFor: 'special'! {IEEEDoubleVar} loadFactor | loadCount {Int32} | loadCount _ Int32Zero. Int32Zero almostTo: numEntries do: [ :i {Int32} | (entries fetch: i) ~~ NULL ifTrue: [ loadCount _ loadCount + 1]]. ^ loadCount asFloat / numEntries asFloat! {UInt32} lowHashBits ^ myLowHashBits! ! !GrandDataPage methodsFor: 'printing'! {void} printOn: aStream {ostream reference} | count {Int32} | aStream << 'GrandDataPage(' << numEntries << ' slots, '. count _ Int32Zero. Int32Zero almostTo: numEntries do: [ :i {Int32} | (entries fetch: i) ~~ NULL ifTrue: [ count _ count + 1 ]]. aStream << count << ' full'. overflow ~~ NULL ifTrue: [ aStream << ' and overflow']. aStream << ')'! ! !GrandDataPage methodsFor: 'protected: destruction'! {void} dismantle DiskManager consistent: 1 + numEntries with: [| entry {Heaper} | entries ~~ NULL ifTrue: [Int32Zero almostTo: numEntries do: [ :i {Int32} | entry _ entries fetch: i. entry ~~ NULL ifTrue: [entry destroy. entries at: i store: NULL]]. entries destroy. entries _ NULL]. super dismantle]! ! !GrandDataPage methodsFor: 'testing'! {UInt32} contentsHash ^((((super contentsHash bitXor: (IntegerPos integerHash: myLowHashBits)) bitXor: (IntegerPos integerHash: numEntries)) bitXor: entries contentsHash) bitXor: overflow hashForEqual) bitXor: myGroup hashForEqual! {BooleanVar} isEmpty UInt32Zero almostTo: numEntries do: [ :i {UInt32} | (entries fetch: i) ~~ NULL ifTrue: [ ^ false ]]. ^ true! ! !GrandDataPage methodsFor: 'private: friendly'! {GrandEntry} entryAt: idx {IntegerVar} ^(entries fetch: idx DOTasLong) cast: GrandEntry! {IntegerVar} entryCount ^ numEntries! ! !GrandDataPage methodsFor: 'private: smalltalk: private'! inspectPieces ^entries asOrderedCollection! ! !GrandDataPage methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myLowHashBits _ receiver receiveUInt32. numEntries _ receiver receiveInt32. entries _ receiver receiveHeaper. overflow _ receiver receiveHeaper. myGroup _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendUInt32: myLowHashBits. xmtr sendInt32: numEntries. xmtr sendHeaper: entries. xmtr sendHeaper: overflow. xmtr sendHeaper: myGroup.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GrandDataPage class instanceVariableNames: ''! (GrandDataPage getOrMakeCxxClassDescription) friends: '/* friends for class GrandDataPage */ friend class GrandDataPageStepper; '; attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !GrandDataPage class methodsFor: 'creation'! make: nEntries {Int32} with: node {GrandNode} with: lowHashBits {UInt32} ^ self create: nEntries with: node with: lowHashBits! !Abraham subclass: #GrandEntry instanceVariableNames: 'objectInternal {Heaper}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Grand'! GrandEntry comment: 'GrandEntries probably want to not be remembered right when they are created, and remembered when they are finally put into their place in the GrandDataPages or GrandOverflows'! (GrandEntry getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #DEFERRED.LOCKED; yourself)! !GrandEntry methodsFor: 'accessing'! {Heaper} value objectInternal == NULL ifTrue: [Heaper BLAST: #NotInTable]. ^ objectInternal! ! !GrandEntry methodsFor: 'protected: creation'! create: value {Heaper} with: hash {UInt32} super create: hash. value == NULL ifTrue: [Heaper BLAST: #NullInsertion]. [value == nil ifTrue: [Heaper BLAST: #NullInsertion]] smalltalkOnly. objectInternal _ value.! ! !GrandEntry methodsFor: 'deferred: testing'! {BooleanVar} compare: anObj {Heaper | Position} self subclassResponsibility! {BooleanVar} matches: anEntry {GrandEntry} self subclassResponsibility! ! !GrandEntry methodsFor: 'testing'! {UInt32} contentsHash ^(super contentsHash bitXor: (IntegerPos integerHash: self hashForEqual)) bitXor: objectInternal hashForEqual! ! !GrandEntry methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. objectInternal _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: objectInternal.! !GrandEntry subclass: #GrandSetEntry instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Grand'! (GrandSetEntry getOrMakeCxxClassDescription) attributes: ((Set new) add: #COPY; add: #SHEPHERD.ANCESTOR; add: #LOCKED; add: #NOT.A.TYPE; add: #CONCRETE; yourself)! !GrandSetEntry methodsFor: 'testing'! {BooleanVar} compare: anObj {Heaper | Position} ^ self value isEqual: anObj! {BooleanVar} matches: anEntry {GrandEntry} ^ self value isEqual: anEntry value! ! !GrandSetEntry methodsFor: 'protected: creation'! create: value {Heaper} with: hash {UInt32} super create: value with: hash. self newShepherd. self remember! ! !GrandSetEntry methodsFor: 'printing'! {void} printOn: aStream {ostream reference} aStream << 'GrandSetEntry(hash=' << self hashForEqual << ', value=' << self value << ')'! ! !GrandSetEntry methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GrandSetEntry class instanceVariableNames: ''! (GrandSetEntry getOrMakeCxxClassDescription) attributes: ((Set new) add: #COPY; add: #SHEPHERD.ANCESTOR; add: #LOCKED; add: #NOT.A.TYPE; add: #CONCRETE; yourself)! !GrandSetEntry class methodsFor: 'create'! {GrandEntry} make: value {Heaper} with: hash {UInt32} ^ self create: value with: hash! !GrandEntry subclass: #GrandTableEntry instanceVariableNames: 'keyInternal {Position}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Grand'! (GrandTableEntry getOrMakeCxxClassDescription) attributes: ((Set new) add: #COPY; add: #SHEPHERD.ANCESTOR; add: #LOCKED; add: #NOT.A.TYPE; add: #CONCRETE; yourself)! !GrandTableEntry methodsFor: 'printing'! {void} printOn: aStream {ostream reference} aStream << 'GrandTableEntry(hash=' << self hashForEqual << ', key='<< keyInternal << ', value=' << self value << ')'! ! !GrandTableEntry methodsFor: 'accessing'! {Position} key ^ keyInternal! {Position} position ^ keyInternal! ! !GrandTableEntry methodsFor: 'testing'! {BooleanVar} compare: anObj {Heaper | Position} ^ keyInternal isEqual: anObj! {UInt32} contentsHash ^super contentsHash bitXor: keyInternal hashForEqual! {BooleanVar} matches: anEntry {GrandEntry} ^ keyInternal isEqual: (anEntry cast: GrandTableEntry) position! ! !GrandTableEntry methodsFor: 'protected: creation'! create: value {Heaper} with: key {Position} with: hash {UInt32} super create: value with: hash. keyInternal _ key. self newShepherd. self remember! ! !GrandTableEntry methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. keyInternal _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: keyInternal.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GrandTableEntry class instanceVariableNames: ''! (GrandTableEntry getOrMakeCxxClassDescription) attributes: ((Set new) add: #COPY; add: #SHEPHERD.ANCESTOR; add: #LOCKED; add: #NOT.A.TYPE; add: #CONCRETE; yourself)! !GrandTableEntry class methodsFor: 'create'! {GrandEntry} make: value {Heaper} with: key {Position} with: hash {UInt32} ^ self create: value with: key with: hash! !Abraham subclass: #GrandNode instanceVariableNames: ' primaryPages {PtrArray of: GrandDataPage} numPrimaries {Int32} overflowRoot {GrandOverflow} oldOverflowRoot {GrandOverflow} numReinserters {Int32}' classVariableNames: 'OverflowPageSize {Int32} ' poolDictionaries: '' category: 'Xanadu-Collection-Grand'! GrandNode comment: 'oldOverflowRoot holds onto the overflow tree that was in place when a node doubling starts. It allows an object stored to be found at any time during the doubling.'! (GrandNode getOrMakeCxxClassDescription) friends: '/* friends for class GrandNode */ friend class GrandNodeStepper; friend class GrandNodeDoubler; friend class GrandNodeReinserter; '; attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !GrandNode methodsFor: 'accessing'! {Heaper} fetch: toMatch {Heaper | Position} with: aHash {UInt32} | result {Heaper} | result _ ((primaryPages fetch: aHash \\ numPrimaries) cast: GrandDataPage) fetch: toMatch with: aHash with: numPrimaries. result ~~ NULL ifTrue: [ ^ result ]. oldOverflowRoot ~~ NULL ifTrue: [^oldOverflowRoot fetch: toMatch with: aHash]. ^ NULL! {void} store.Entry: newEntry {GrandEntry} ((primaryPages fetch: newEntry hashForEqual \\ numPrimaries) cast: GrandDataPage) store.Entry: newEntry with: numPrimaries! {void} wipe: toMatch {Heaper | Position} with: aHash {UInt32} ((primaryPages fetch: aHash \\ numPrimaries) cast: GrandDataPage) wipe: toMatch with: aHash with: numPrimaries. oldOverflowRoot ~~ NULL ifTrue: [oldOverflowRoot wipe: toMatch with: aHash]! ! !GrandNode methodsFor: 'printing'! {void} printOn: aStream {ostream reference} aStream << 'GrandNode(numPages=' << numPrimaries << ')'! ! !GrandNode methodsFor: 'protected: creation'! create | aPage {GrandDataPage} | super create. overflowRoot _ NULL. oldOverflowRoot _ NULL. numReinserters _ Int32Zero. numPrimaries _ 1. primaryPages _ PtrArray nulls: 1. aPage _ GrandDataPage make: GrandNode primaryPageSize with: self with: UInt32Zero. primaryPages at: Int32Zero store: aPage. self newShepherd. self remember! {void} dismantle DiskManager consistent: 2 + numPrimaries with: [| page {Heaper} | primaryPages ~~ NULL ifTrue: [Int32Zero almostTo: numPrimaries do: [:i {Int32} | page _ (primaryPages fetch: i). page ~~ NULL ifTrue: [page destroy]]. primaryPages destroy]. overflowRoot ~~ NULL ifTrue: [overflowRoot destroy]. oldOverflowRoot ~~ NULL ifTrue: [oldOverflowRoot destroy]. super dismantle]! ! !GrandNode methodsFor: 'node doubling'! {void} addReinserter DiskManager consistent: 1 with: [numReinserters _ numReinserters + 1. self diskUpdate]! {void} doubleNode | newPage {GrandDataPage} newNumPrimaries {Int32} newPrimaries {PtrArray of: GrandDataPage} | DiskManager consistent: self doubleNodeConsistency with: [newNumPrimaries _ numPrimaries * 2. newPrimaries _ PtrArray nulls: newNumPrimaries. Int32Zero almostTo: numPrimaries do: [:i {Int32} | newPage _ ((primaryPages fetch: i) cast: GrandDataPage) makeDouble: newNumPrimaries. newPrimaries at: i store: (primaryPages fetch: i). newPrimaries at: newPage lowHashBits store: newPage]. primaryPages destroy. primaryPages _ newPrimaries. numPrimaries _ newNumPrimaries. "At this point, the structure is consistent, but still doesn't have the full benefit of the node doubling. Inserts will be faster now, but reinsertion of the overflow data is required for fetch to improve." overflowRoot ~~ NULL ifTrue: [oldOverflowRoot ~~ NULL ifTrue: [Heaper BLAST: #FallenBehindInNodeDoubling]. oldOverflowRoot _ overflowRoot. overflowRoot _ NULL. (GrandNodeReinserter make: self with: oldOverflowRoot) schedule]. self diskUpdate].! {IntegerVar} doubleNodeConsistency Eric knownBug. "Sometimes this is off by one in either direction" ^ 2 * numPrimaries + 2! {void} removeReinserter DiskManager consistent: 1 with: [numReinserters _ numReinserters - 1. numReinserters == Int32Zero ifTrue: [oldOverflowRoot destroy. oldOverflowRoot _ NULL]. self diskUpdate]! ! !GrandNode methodsFor: 'private: friendly access'! {GrandDataPage} pageAt: idx {IntegerVar} ^ (primaryPages fetch: idx DOTasLong) cast: GrandDataPage! {IntegerVar} pageCount ^ numPrimaries! ! !GrandNode methodsFor: 'testing'! {UInt32} contentsHash | result {UInt32} | result _ ((super contentsHash bitXor: primaryPages contentsHash) bitXor: (IntegerPos integerHash: numPrimaries)). overflowRoot ~~ NULL ifTrue: [result _ result bitXor: overflowRoot hashForEqual]. oldOverflowRoot ~~ NULL ifTrue: [result _ result bitXor: oldOverflowRoot hashForEqual]. ^ result! {BooleanVar} isEmpty UInt32Zero almostTo: numPrimaries do: [ :i {UInt32} | ((primaryPages fetch: i) cast: GrandDataPage) isEmpty ifFalse: [ ^ false ]]. ^ overflowRoot == NULL and: [oldOverflowRoot == NULL]! ! !GrandNode methodsFor: 'smalltalk: inspection'! inspect EntView make: self! inspectPieces | result | result _ primaryPages asOrderedCollection. overflowRoot ~~ NULL ifTrue: [result add: overflowRoot]. oldOverflowRoot ~~ NULL ifTrue: [result add: oldOverflowRoot]. ^result! ! !GrandNode methodsFor: 'overflow'! {GrandOverflow} fetchOldOverflow ^ oldOverflowRoot! {GrandOverflow} fetchOverflow ^overflowRoot! {GrandOverflow} getOverflow overflowRoot == NULL ifTrue: [DiskManager consistent: 2 with: [overflowRoot _ GrandOverflow create: OverflowPageSize with: 1. self diskUpdate]]. ^overflowRoot! ! !GrandNode methodsFor: 'special'! {IEEEDoubleVar} loadFactor | loadSum {IEEEDoubleVar} | loadSum _ 0.0. Int32Zero almostTo: numPrimaries do: [ :i {Int32} | loadSum _ loadSum + (((primaryPages fetch: i) cast: GrandDataPage) loadFactor)]. ^ loadSum / numPrimaries! ! !GrandNode methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. primaryPages _ receiver receiveHeaper. numPrimaries _ receiver receiveInt32. overflowRoot _ receiver receiveHeaper. oldOverflowRoot _ receiver receiveHeaper. numReinserters _ receiver receiveInt32.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: primaryPages. xmtr sendInt32: numPrimaries. xmtr sendHeaper: overflowRoot. xmtr sendHeaper: oldOverflowRoot. xmtr sendInt32: numReinserters.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GrandNode class instanceVariableNames: ''! (GrandNode getOrMakeCxxClassDescription) friends: '/* friends for class GrandNode */ friend class GrandNodeStepper; friend class GrandNodeDoubler; friend class GrandNodeReinserter; '; attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !GrandNode class methodsFor: 'smalltalk: smalltalk initialization'! linkTimeNonInherited OverflowPageSize _ 8! ! !GrandNode class methodsFor: 'create'! make ^ self create! ! !GrandNode class methodsFor: 'static functions'! {Int32 INLINE} primaryPageSize ^ 128! !Abraham subclass: #GrandOverflow instanceVariableNames: ' numEntries {Int32} entries {PtrArray of: GrandEntry} children {PtrArray of: GrandOverflow} depth {Int32}' classVariableNames: 'OTreeArity {Int32} ' poolDictionaries: '' category: 'Xanadu-Collection-Grand'! GrandOverflow comment: 'This class has a comment The instance variable depth actually holds the value OTreeArity ^ depth.'! (GrandOverflow getOrMakeCxxClassDescription) friends: '/* friends for class GrandOverflow */ friend class GrandOverflowStepper;'; attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !GrandOverflow methodsFor: 'accessing'! {Heaper} fetch: toMatch {Heaper | Position} with: aHash {UInt32} | localIndex {Int32} originalIndex {Int32} entry {GrandEntry} childIndex {UInt32} | localIndex _ originalIndex _ aHash // depth \\ numEntries. entry _ (entries fetch: localIndex) cast: GrandEntry. [entry ~~ NULL] whileTrue: [(aHash == entry hashForEqual) ifTrue: [(entry compare: toMatch) ifTrue: [^ entry value]]. localIndex _ localIndex + 1 \\ numEntries. entry _ (entries fetch: localIndex) cast: GrandEntry. localIndex == originalIndex ifTrue: [entry _ NULL "break from loop"]]. childIndex _ aHash // depth \\ OTreeArity. (children fetch: childIndex) ~~ NULL ifTrue: [^ ((children fetch: childIndex) cast: GrandOverflow) fetch: toMatch with: aHash]. ^NULL! {GrandOverflow} store.Entry: newEntry {GrandEntry} | localIndex {Int32} originalIndex {Int32} entry {GrandEntry wimpy} | localIndex _ originalIndex _ newEntry hashForEqual // depth \\ numEntries. entry _ (entries fetch: localIndex) cast: GrandEntry. [entry ~~ NULL] whileTrue: [newEntry hashForEqual == entry hashForEqual ifTrue: [(newEntry matches: entry) ifTrue: ["Note that this does not delete the contents" DiskManager consistent: 2 with: [entry destroy. entries at: localIndex store: newEntry. self diskUpdate]. ^self]]. localIndex _ localIndex + 1 \\ numEntries. localIndex == originalIndex ifTrue: [| newChild {GrandOverflow} childIndex {UInt32} | "This page is now full. Descend overflow tree further." childIndex _ newEntry hashForEqual // depth \\ OTreeArity. (children fetch: childIndex) == NULL ifTrue: [DiskManager consistent: 2 with: [newChild _ GrandOverflow create: numEntries with: depth * OTreeArity. children at: childIndex store: newChild. self diskUpdate]]. ^((children fetch: childIndex) cast: GrandOverflow) store.Entry: newEntry]. entry _ (entries fetch: localIndex) cast: GrandEntry]. "Found empty slot." DiskManager consistent: 1 with: [entries at: localIndex store: newEntry. self diskUpdate]. ^self! {void} wipe: toMatch {Heaper | Position} with: aHash {UInt32} | localIndex {Int32} originalIndex {Int32} childIndex {Int32} entry {GrandEntry wimpy} | localIndex _ originalIndex _ aHash // depth \\ numEntries. entry _ (entries fetch: localIndex) cast: GrandEntry. [entry ~~ NULL] whileTrue: [aHash == entry hashForEqual ifTrue: [(entry compare: toMatch) ifTrue: ["Note that this does not delete the contents" DiskManager consistent: 2 with: [entry destroy. entries at: localIndex store: NULL. self repack. self diskUpdate]. ^ VOID]]. localIndex _ localIndex + 1 \\ numEntries. entry _ (entries fetch: localIndex) cast: GrandEntry. localIndex == originalIndex ifTrue: ["break from loop" entry _ NULL]]. childIndex _ aHash // depth \\ OTreeArity. (children fetch: childIndex) ~~ NULL ifTrue: [((children fetch: childIndex) cast: GrandOverflow) wipe: toMatch with: aHash]! ! !GrandOverflow methodsFor: 'creation'! create: maxEntries {Int32} with: someDepth {UInt32} super create. numEntries _ maxEntries. entries _ PtrArray nulls: numEntries. children _ PtrArray nulls: OTreeArity. depth _ someDepth. self newShepherd. self remember! ! !GrandOverflow methodsFor: 'private:'! {void} repack "This repacks the entry table after a wipe to keep the table consistent with" "the linear hash collision resolution technique." | newEntries {PtrArray of: GrandEntry} entry {GrandEntry} preferedIndex {Int32} | newEntries _ PtrArray nulls: numEntries. Int32Zero almostTo: numEntries do: [ :i {Int32} | (entry _ (entries fetch: i) cast: GrandEntry) ~~ NULL ifTrue: [preferedIndex _ entry hashForEqual // depth \\ numEntries. (newEntries fetch: preferedIndex) ~~ NULL ifTrue: [[(newEntries fetch: preferedIndex) ~~ NULL] whileTrue: [preferedIndex _ preferedIndex + 1 \\ numEntries]]. newEntries at: preferedIndex store: entry]]. entries destroy. entries _ newEntries! ! !GrandOverflow methodsFor: 'node doubling'! {void} reinsertEntries: node {GrandNode} "Recursively insert all overflowed entries into a newly doubled node." | entry {GrandEntry} child {GrandOverflow} | DiskManager consistent: self reinsertEntriesConsistency with: [Int32Zero almostTo: numEntries do: [ :i {Int32} | entry _ (entries fetch: i) cast: GrandEntry. entry ~~ NULL ifTrue: [node store.Entry: entry. entries at: i store: NULL. self diskUpdate]]. Int32Zero almostTo: OTreeArity do: [ :j {Int32} | child _ (children fetch: j) cast: GrandOverflow. child ~~ NULL ifTrue: [(GrandNodeReinserter make: node with: child) schedule]]]! {IntegerVar} reinsertEntriesConsistency ^ 4 * numEntries + OTreeArity + 2! ! !GrandOverflow methodsFor: 'printing'! {void} printOn: aStream {ostream reference} aStream << 'GrandOverflow(depth=' << depth << ')'! ! !GrandOverflow methodsFor: 'protected: creation'! {void} dismantle DiskManager consistent: 1 + numEntries + OTreeArity with: [entries ~~ NULL ifTrue: [Int32Zero almostTo: numEntries do: [ :i {Int32} | | entry {GrandEntry} | entry _ (entries fetch: i) cast: GrandEntry. entry ~~ NULL ifTrue: [entry destroy]]. entries destroy]. children ~~ NULL ifTrue: [Int32Zero almostTo: OTreeArity do: [ :j {Int32} | | child {GrandOverflow} | child _ (children fetch: j) cast: GrandOverflow. child ~~ NULL ifTrue: [child destroy]]. children destroy]. super dismantle]! ! !GrandOverflow methodsFor: 'private: friendly'! {GrandOverflow} childAt: idx {IntegerVar} ^ (children fetch: idx DOTasLong) cast: GrandOverflow! {IntegerVar} childCount ^ OTreeArity! {GrandEntry} entryAt: idx {IntegerVar} ^ (entries fetch: idx DOTasLong) cast: GrandEntry! {IntegerVar} entryCount ^ numEntries! ! !GrandOverflow methodsFor: 'private: smalltalk: private'! inspectPieces ^(entries asOrderedCollection) addAll: children asOrderedCollection; yourself! ! !GrandOverflow methodsFor: 'testing'! {UInt32} contentsHash ^(((super contentsHash bitXor: (IntegerPos integerHash: numEntries)) bitXor: entries contentsHash) bitXor: children contentsHash) bitXor: (IntegerPos integerHash: depth)! ! !GrandOverflow methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. numEntries _ receiver receiveInt32. entries _ receiver receiveHeaper. children _ receiver receiveHeaper. depth _ receiver receiveInt32.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendInt32: numEntries. xmtr sendHeaper: entries. xmtr sendHeaper: children. xmtr sendInt32: depth.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GrandOverflow class instanceVariableNames: ''! (GrandOverflow getOrMakeCxxClassDescription) friends: '/* friends for class GrandOverflow */ friend class GrandOverflowStepper;'; attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !GrandOverflow class methodsFor: 'smalltalk: smalltalk initialization'! linkTimeNonInherited OTreeArity _ 4! !Abraham subclass: #MultiCounter instanceVariableNames: ' myFirst {Counter} mySecond {Counter}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-counter'! (MultiCounter getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !MultiCounter methodsFor: 'accessing'! {void} decrementBoth DiskManager consistent: 2 with: [myFirst decrement. mySecond decrement]! {IntegerVar} decrementFirst ^myFirst decrement! {IntegerVar} decrementSecond ^mySecond decrement! {IntegerVar} firstCount ^myFirst count! {void} incrementBoth DiskManager consistent: 2 with: [myFirst increment. mySecond increment]! {IntegerVar} incrementFirst ^myFirst increment! {IntegerVar} incrementSecond ^mySecond increment! {IntegerVar} secondCount ^mySecond count! ! !MultiCounter methodsFor: 'creation'! create super create. myFirst _ Counter make: IntegerVar0. mySecond _ Counter make: IntegerVar0. self newShepherd. self remember! create: first {IntegerVar} super create. myFirst _ Counter make: first. mySecond _ Counter make: IntegerVar0. self newShepherd. self remember! create: first {IntegerVar} with: second {IntegerVar} super create. myFirst _ Counter make: first. mySecond _ Counter make: second. self newShepherd. self remember! ! !MultiCounter methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '(' << myFirst count << ', ' << mySecond count << ')'! ! !MultiCounter methodsFor: 'testing'! {UInt32} contentsHash ^(super contentsHash bitXor: myFirst hashForEqual) bitXor: mySecond hashForEqual! ! !MultiCounter methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myFirst _ receiver receiveHeaper. mySecond _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myFirst. xmtr sendHeaper: mySecond.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MultiCounter class instanceVariableNames: ''! (MultiCounter getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !MultiCounter class methodsFor: 'pseudo constructors '! make ^self create.! make: count {IntegerVar} ^self create: count! !Abraham subclass: #OPart instanceVariableNames: 'mySensorCrum {SensorCrum}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Ents'! (OPart getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #COPY; add: #SHEPHERD.ANCESTOR; add: #DEFERRED.LOCKED; yourself)! !OPart methodsFor: 'backfollow'! {XnRegion} attachTrailBlazer: blazer {TrailBlazer} "Attach the TrailBlazer to this Edition, and return the region of partiality it is attached to" self subclassResponsibility! {void} checkTrailBlazer: blazer {TrailBlazer} "Make sure that everyone below here that might have a TrailBlazer, has the given one" self subclassResponsibility! {TrailBlazer | NULL} fetchTrailBlazer "If there is a TrailBlazer somewhere below this Edition, return one of them" self subclassResponsibility! {HistoryCrum} hCrum self subclassResponsibility! ! !OPart methodsFor: 'accessing'! {Mapping} mappingTo: trace {TracePosition} with: initial {Mapping} "return the mapping into the domain space of the given trace" ^self hCrum mappingTo: trace with: initial! {SensorCrum} sensorCrum ^mySensorCrum! ! !OPart methodsFor: 'protected: delete'! {void} dismantle DiskManager insistent: 2 with: [(Heaper isConstructed: mySensorCrum) ifTrue: [mySensorCrum removePointer: self]. ((Heaper isConstructed: self hCrum) and: [Heaper isConstructed: self hCrum bertCrum]) ifTrue: [self hCrum bertCrum removePointer: self hCrum]. super dismantle]! ! !OPart methodsFor: 'smalltalk:'! hinspect self hCrum inspect! inspect Sensor leftShiftDown ifTrue: [self basicInspect] ifFalse: [EntView openOn: (TreeBarnacle new buildOn: self gettingChildren: [:crum | crum crums] gettingImage: [:crum | DisplayText text: crum displayString asText textStyle: (TextStyle styleNamed: #small)] at: 0 @ 0 vertical: true separation: 5 @ 10)]! inspectCanopy self hCrum bertCrum inspect! inspectMenuArray ^#( ('inspect history' hinspect '') ('bert canopy' inspectCanopy '') ('recorder canopy' inspectRecorderCanopy ''))! inspectRecorderCanopy self sensorCrum inspect! showOn: oo oo << self getCategory name << $( << self hCrum hCut << ', ' << self hCrum asOop << ', ' << self hCrum oParents count << $)! ! !OPart methodsFor: 'protected: create'! create: scrum {SensorCrum | NULL} super create. scrum == NULL ifTrue: [mySensorCrum _ SensorCrum make] ifFalse: [mySensorCrum _ scrum]. mySensorCrum addPointer: self! create: hash {UInt32} with: scrum {SensorCrum | NULL} super create: hash. scrum == NULL ifTrue: [mySensorCrum _ SensorCrum make] ifFalse: [mySensorCrum _ scrum]. mySensorCrum addPointer: self! ! !OPart methodsFor: 'testing'! {UInt32} contentsHash ^super contentsHash bitXor: mySensorCrum hashForEqual! ! !OPart methodsFor: 'smalltalk: passe'! {void} wait: sensor {XnSensor} self passe! ! !OPart methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. mySensorCrum _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: mySensorCrum.! !OPart subclass: #Loaf instanceVariableNames: 'myHCrum {HUpperCrum}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Ents'! (Loaf getOrMakeCxxClassDescription) attributes: ((Set new) add: #SHEPHERD.PATRIARCH; add: #COPY; add: #DEFERRED; add: #DEFERRED.LOCKED; yourself)! !Loaf methodsFor: 'accessing'! {Mapping} compare: trace {TracePosition} with: region {XnRegion} "return a mapping from my data to corresponding stuff in the given trace" self subclassResponsibility! {IntegerVar} count self subclassResponsibility! {XnRegion} domain self subclassResponsibility! {FeRangeElement | NULL} fetch: key {Position} with: edition {BeEdition} with: globalKey {Position} "Look up the range element for the key. If it is embedded within a virtual structure, then make a virtual range element using the edition and globalKey." self thingToDo. "This should softSplay the position up." self subclassResponsibility! {OExpandingLoaf} fetchBottomAt: key {Position} "Return the bottom-most Loaf. Used to get the owner and such of a position." self subclassResponsibility! {void} fill: keys {XnRegion} with: toArrange {Arrangement} with: toArray {PrimArray} with: globalDsp {Dsp} with: edition {BeEdition} "Fill an array with my contents" self subclassResponsibility! {BeRangeElement} getBe: key {Position} "Get or Make the BeRangeElement at the location." self subclassResponsibility! {XnRegion} rangeOwners: positions {XnRegion | NULL} self subclassResponsibility! {OrglRoot} setAllOwners: owner {ID} "Recur assigning owners. Return the portion of the o-tree that couldn't be assigned, or NULL if it was all assigned." self subclassResponsibility! {XnRegion} usedDomain self subclassResponsibility! ! !Loaf methodsFor: 'operations'! {Stepper} bundleStepper: region {XnRegion} with: order {OrderSpec} with: globalDsp {Dsp} "Return a stepper of bundles according to the order." self subclassResponsibility! {OrglRoot} combine: another {ActualOrglRoot} with: limitRegion {XnRegion} with: globalDsp {Dsp} self subclassResponsibility! {XnRegion} keysLabelled: label {BeLabel} "Just search for now." self subclassResponsibility! {XnRegion} sharedRegion: trace {TracePosition} with: limitRegion {XnRegion} "Return a region describing the stuff that can backfollow to trace." self subclassResponsibility! {Loaf} transformedBy: externalDsp {Dsp} "Return a copy with externalDsp added to the receiver's dsp." externalDsp isIdentity ifTrue: [^self] ifFalse: [^InnerLoaf make: self with: externalDsp]! {Loaf} unTransformedBy: globalDsp {Dsp} "Return a copy with globalDsp removed from the receiver's dsp." globalDsp isIdentity ifTrue: [^self] ifFalse: [^InnerLoaf make: self with: (globalDsp inverse cast: Dsp)]! ! !Loaf methodsFor: 'splay'! {UInt8} splay: region {XnRegion} with: limitRegion {XnRegion} "Make each child completely contained or completely outside the region. Return the number of children completely in the region. Full containment cases can be handled generically." (limitRegion isSubsetOf: region) ifTrue: [^2] ifFalse: [(limitRegion intersects: region) ifTrue: [^self actualSplay: region with: limitRegion] ifFalse: [^Int0]]! ! !Loaf methodsFor: 'protected: splay'! {Int8} actualSplay: region {XnRegion} with: limitRegion {XnRegion} "Speciall handle the splay cases in which the region partially intersects with limitedRegion. These require rotations and splitting." self subclassResponsibility! ! !Loaf methodsFor: 'backfollow'! {void} addOParent: oParent {OPart} "This should probably take a bertCanopyCrum argument, as well." "add oParent to the set of upward pointers." myHCrum addOParent: oParent. self remember. self diskUpdate! {XnRegion} attachTrailBlazer: blazer {TrailBlazer} self subclassResponsibility! {void} checkChildRecorders: finder {PropFinder} "send checkRecorders to all children" self subclassResponsibility! {void} checkRecorders: finder {PropFinder} with: scrum {SensorCrum | NULL} "check any recorders that might be triggered by a change in the edition. Walk leafward on O-plane, filtered by sensor canopy, ringing recorders. Not in a consistent block: It spawns unbounded work. " | newFinder {PropFinder} | "Shrink finder to just what may be on this branch of O-tree. If there might be something on this branch Check the children using the simplified finder." newFinder _ self sensorCrum checkRecorders: finder with: scrum. newFinder isEmpty ifFalse: [self checkChildRecorders: newFinder]! {void} checkTrailBlazer: blazer {TrailBlazer} self subclassResponsibility! {void} delayedStoreMatching: finder {PropFinder} with: fossil {RecorderFossil} with: recorder {ResultRecorder} with: hCrumCache {HashSetCache of: HistoryCrum} "One step of walk south on the O-tree during the 'now' part of a backfollow." self subclassResponsibility! {TrailBlazer | NULL} fetchTrailBlazer self subclassResponsibility! {HistoryCrum} hCrum ^myHCrum! {void} removeOParent: oparent {OPart} "remove oparent from the set of upward pointers." myHCrum removeOParent: oparent. myHCrum isEmpty ifTrue: ["Now we get into the risky part of deletion. There are no more upward pointers, so destroy the receiver." self destroy] ifFalse: [self diskUpdate]! {void} storeRecordingAgents: recorder {RecorderFossil} with: agenda {Agenda} "Go ahead and actually store the recorder in the sensor canopy. However, instead of propogating the props immediately, accumulate all those agenda items into the 'agenda' parameter. This is done instead of scheduling them directly because our client needs to schedule something else following all the prop propogation." self subclassResponsibility! {void} triggerDetector: detect {FeFillRangeDetector} "A Detector has been added to my parent. Walk down and trigger it on all non-partial stuff" self subclassResponsibility! {BooleanVar} updateBCrumTo: newBCrum {BertCrum} "Ensure the my bertCrum is not be leafward of newBCrum." (myHCrum propagateBCrum: newBCrum) ifTrue: [self diskUpdate. ^true]. ^false! ! !Loaf methodsFor: 'protected:'! {FeEdition} asFeEdition "Make a FeEdition out of myself. Used for triggering Detectors" CurrentTrace fluidBind: self hCrum hCut during: [CurrentBertCrum fluidBind: self hCrum bertCrum during: [^FeEdition on: (BeEdition make: (ActualOrglRoot make: self with: self domain))]]! {void} dismantle DiskManager insistent: 2 with: [super dismantle. myHCrum _ NULL]! ! !Loaf methodsFor: 'create'! create: hcrum {HUpperCrum | NULL} with: scrum {SensorCrum | NULL} super create: scrum. hcrum == NULL ifTrue: [myHCrum _ HUpperCrum make] ifFalse: [myHCrum _ hcrum]! create: hash {UInt32} with: hcrum {HUpperCrum | NULL} with: scrum {SensorCrum | NULL} super create: hash with: scrum. hcrum == NULL ifTrue: [myHCrum _ HUpperCrum make] ifFalse: [myHCrum _ hcrum]! ! !Loaf methodsFor: 'testing'! {UInt32} contentsHash ^super contentsHash bitXor: myHCrum hashForEqual! ! !Loaf methodsFor: 'smalltalk: passe'! {void} checkChildRecorders: stamp {BeEdition} with: finder {PropFinder} self passe "fewer args"! {void} checkRecorders: edition {BeEdition} with: finder {PropFinder} with: scrum {SensorCrum | NULL} self passe "fewer args"! {void} delayedStoreMatching: finder {PropFinder} with: recorder {RecorderFossil} with: hCrumCache {HashSetCache of: HistoryCrum} self passe "extra argument"! {void} inform: key {Position} with: value {HRoot} with: trace {TracePosition} "inform a piece of partiality" self passe! {void} storeMatching: finder {PropFinder} with: table {MuTable of: ID and: BeEdition} with: hCrumCache {HashSetCache of: HistoryCrum} self passe! {void} wait: sensor {XnSensor} self passe! ! !Loaf methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myHCrum _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myHCrum.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Loaf class instanceVariableNames: ''! (Loaf getOrMakeCxxClassDescription) attributes: ((Set new) add: #SHEPHERD.PATRIARCH; add: #COPY; add: #DEFERRED; add: #DEFERRED.LOCKED; yourself)! !Loaf class methodsFor: 'create'! {Loaf} make.Region: region {XnRegion} with: element {BeCarrier} DiskManager consistent: 7 with: [^RegionLoaf create: region with: element fetchLabel with: element rangeElement with: NULL]! make.XnRegion: region {XnRegion} DiskManager consistent: 3 with: [^OPartialLoaf create: region with: NULL with: SensorCrum partial]! make: values {PrimDataArray} with: arrangement {Arrangement} DiskManager consistent: 4 with: [| tmp {SharedData} | tmp _ SharedData create: values with: arrangement. ^OVirtualLoaf create: arrangement region with: tmp]! !Loaf subclass: #InnerLoaf instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Ents'! (InnerLoaf getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #COPY; add: #SHEPHERD.ANCESTOR; add: #DEFERRED.LOCKED; yourself)! !InnerLoaf methodsFor: 'create'! create: hcrum {HUpperCrum} with: scrum {SensorCrum} super create: hcrum with: scrum! create: hash {UInt32} with: hcrum {HUpperCrum} with: scrum {SensorCrum} super create: hash with: hcrum with: scrum! ! !InnerLoaf methodsFor: 'protected: splay'! {Int8} actualSplay: region {XnRegion} with: limitRegion {XnRegion} "Special handle the splay cases in which the region partially intersects with limitedRegion. These require rotations and splitting." self subclassResponsibility! ! !InnerLoaf methodsFor: 'accessing'! {Mapping} compare: trace {TracePosition} with: region {XnRegion} "return a mapping from my data to corresponding stuff in the given trace" self subclassResponsibility! {IntegerVar} count self subclassResponsibility! {XnRegion} domain self subclassResponsibility! {FeRangeElement | NULL} fetch: key {Position} with: edition {BeEdition} with: globalKey {Position} self subclassResponsibility! {OExpandingLoaf} fetchBottomAt: key {Position} "Return the bottom-most Loaf. Used to get the owner and such of a position." self subclassResponsibility! {void} fill: keys {XnRegion} with: toArrange {Arrangement} with: toArray {PrimArray} with: globalDsp {Dsp} with: edition {BeEdition} self subclassResponsibility! {BeRangeElement} getBe: key {Position} "Get or Make the BeRangeElement at the location." self subclassResponsibility! {Loaf} inPart "This is used by the splay algorithms." self subclassResponsibility! {Loaf} outPart "This is used by the splay algorithms." self subclassResponsibility! {XnRegion} rangeOwners: positions {XnRegion | NULL} self subclassResponsibility! {OrglRoot} setAllOwners: owner {ID} "Recur assigning owners. Return the portion of the o-tree that couldn't be assigned, or NULL if it was all assigned." self subclassResponsibility! {XnRegion} usedDomain self subclassResponsibility! ! !InnerLoaf methodsFor: 'backfollow'! {XnRegion} attachTrailBlazer: blazer {TrailBlazer} self subclassResponsibility! {void} checkChildRecorders: finder {PropFinder} self subclassResponsibility! {void} checkTrailBlazer: blazer {TrailBlazer} self subclassResponsibility! {void} delayedStoreMatching: finder {PropFinder} with: fossil {RecorderFossil} with: recorder {ResultRecorder} with: hCrumCache {HashSetCache of: HistoryCrum} "Inner loaf: Just forward south to all children." self subclassResponsibility! {TrailBlazer | NULL} fetchTrailBlazer self subclassResponsibility! {void} storeRecordingAgents: recorder {RecorderFossil} with: agenda {Agenda} self subclassResponsibility! {void} triggerDetector: detect {FeFillRangeDetector} self subclassResponsibility! ! !InnerLoaf methodsFor: 'operations'! {Stepper} bundleStepper: region {XnRegion} with: order {OrderSpec} with: globalDsp {Dsp} "Return a stepper of bundles according to the order." self subclassResponsibility! {OrglRoot} combine: another {ActualOrglRoot} with: limitRegion {XnRegion} with: globalDsp {Dsp} self subclassResponsibility! {XnRegion} keysLabelled: label {BeLabel} "Just search for now." self subclassResponsibility! {XnRegion} sharedRegion: trace {TracePosition} with: limitRegion {XnRegion} "Return a region describing the stuff that can backfollow to trace." self subclassResponsibility! ! !InnerLoaf methodsFor: 'smalltalk: passe'! {void} wait: sensor {XnSensor} self passe! ! !InnerLoaf methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! InnerLoaf class instanceVariableNames: ''! (InnerLoaf getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #COPY; add: #SHEPHERD.ANCESTOR; add: #DEFERRED.LOCKED; yourself)! !InnerLoaf class methodsFor: 'create'! make: newO {Loaf} with: dsp {Dsp} "Make a loaf that transforms the contents of newO." DiskManager consistent: 11 with: [^DspLoaf create: newO with: dsp]! make: newSplit {XnRegion} with: newIn {Loaf} with: newOut {Loaf} "The contents of newIn must be completely contained in newSplit. newOut must be completely outside newSplit. Should this just forward to make:with:with:with:? This should extract shared dsp from newIn and newOut." DiskManager consistent: -1 with: [^SplitLoaf create: newSplit with: newIn with: newOut]! make: newSplit {XnRegion} with: newIn {Loaf} with: newOut {Loaf} with: hcrum {HUpperCrum} "The contents of newIn must be completely contained in newSplit. newOut must be completely outside newSplit" DiskManager consistent: 6 with: [^SplitLoaf create: newSplit with: newIn with: newOut with: hcrum]! !InnerLoaf subclass: #DspLoaf instanceVariableNames: ' myDsp {Dsp} myO {Loaf}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Ents'! (DspLoaf getOrMakeCxxClassDescription) attributes: ((Set new) add: #COPY; add: #SHEPHERD.ANCESTOR; add: #LOCKED; add: #NOT.A.TYPE; add: #CONCRETE; yourself)! !DspLoaf methodsFor: 'accessing'! {Mapping} compare: trace {TracePosition} with: region {XnRegion} "return a mapping from my data to corresponding stuff in the given trace" ^(myO compare: trace with: (myDsp inverseOfAll: region)) transformedBy: (myDsp inverse cast: Dsp)! {IntegerVar} count ^myO count! {XnRegion} domain ^myDsp ofAll: myO domain! {FeRangeElement | NULL} fetch: key {Position} with: edition {BeEdition} with: globalKey {Position} "Look up the range element for the key. If it is embedded within a virtual structure, then make a virtual range element using the edition and globalKey." ^myO fetch: (myDsp inverseOf: key) with: edition with: globalKey! {OExpandingLoaf} fetchBottomAt: key {Position} "Return the bottom-most Loaf. Used to get the owner and such of a position." ^myO fetchBottomAt: (myDsp inverseOf: key)! {void} fill: keys {XnRegion} with: toArrange {Arrangement} with: toArray {PrimArray} with: globalDsp {Dsp} with: edition {BeEdition} "Make an FeRangeElement for each position." keys isEmpty ifFalse: [myO fill: (myDsp inverseOfAll: keys) with: toArrange with: toArray with: (globalDsp compose: myDsp) with: edition]! {BeRangeElement} getBe: key {Position} "Get or Make the BeRangeElement at the location." ^myO getBe: (myDsp inverseOf: key)! {Loaf} inPart "This is used by the splay algorithms." ^(myO cast: InnerLoaf) inPart transformedBy: myDsp! {Mapping} mappingTo: trace {TracePosition} with: initial {Mapping} "return the mapping into the domain space of the given trace" ^self hCrum mappingTo: trace with: (initial preCompose: myDsp)! {Loaf} outPart "This is used by the splay algorithms." ^(myO cast: InnerLoaf) outPart transformedBy: myDsp! {XnRegion} rangeOwners: positions {XnRegion | NULL} positions == NULL ifTrue: [^myO rangeOwners: NULL]. positions isEmpty ifTrue: [^IDSpace global emptyRegion] ifFalse: [^myO rangeOwners: (myDsp inverseOfAll: positions)]! {OrglRoot} setAllOwners: owner {ID} "Recur assigning owners. Return the portion of the o-tree that couldn't be assigned." ^(myO setAllOwners: owner) transformedBy: myDsp! {XnRegion} usedDomain ^myDsp ofAll: myO usedDomain! ! !DspLoaf methodsFor: 'protected: splay'! {Int8} actualSplay: region {XnRegion} with: limitRegion {XnRegion} "Make each child completely contained or completely outside the region. Return the number of children completely in the region." | dsp {Dsp} | dsp _ myDsp. ^myO splay: (dsp inverseOfAll: region) with: (dsp inverseOfAll: limitRegion)! ! !DspLoaf methodsFor: 'operations'! {Stepper} bundleStepper: region {XnRegion} with: order {OrderSpec} with: globalDsp {Dsp} "Return a stepper of bundles according to the order." ^myO bundleStepper: region with: order with: (globalDsp compose: myDsp)! {OrglRoot} combine: another {ActualOrglRoot} with: limitRegion {XnRegion} with: globalDsp {Dsp} "Accumulate dsp downward." ^myO combine: another with: limitRegion with: (globalDsp compose: myDsp)! {XnRegion} keysLabelled: label {BeLabel} "Just search for now." ^myDsp ofAll: (myO keysLabelled: label)! {XnRegion} sharedRegion: trace {TracePosition} with: limitRegion {XnRegion} "Return a region describing the stuff that can backfollow to trace." (self hCrum inTrace: trace) ifTrue: [^self domain] ifFalse: [^myDsp ofAll: (myO sharedRegion: trace with: (myDsp inverseOfAll: limitRegion))]! {Loaf} transformedBy: externalDsp {Dsp} "Return a copy with externalDsp added to the receiver's dsp." externalDsp isIdentity ifTrue: [^self] ifFalse: [^myO transformedBy: (externalDsp compose: myDsp)]! {Loaf} unTransformedBy: externalDsp {Dsp} "Return a copy with externalDsp removed from the receiver's dsp." externalDsp isIdentity ifTrue: [^self] ifFalse: [^myO unTransformedBy: (myDsp minus: externalDsp)]! ! !DspLoaf methodsFor: 'printing'! {void} printOn: aStream {ostream reference} aStream << '(' << myDsp << ')'! ! !DspLoaf methodsFor: 'backfollow'! {void} addOParent: oparent {OPart} "add oparent to the set of upward pointers and update the bertCrums my child." | bCrum {BertCrum} newBCrum {BertCrum} | bCrum _ self hCrum bertCrum. super addOParent: oparent. newBCrum _ self hCrum bertCrum. (bCrum isLE: newBCrum) not ifTrue: [myO updateBCrumTo: newBCrum]! {XnRegion} attachTrailBlazer: blazer {TrailBlazer} ^myDsp ofAll: (myO attachTrailBlazer: blazer)! {void} checkChildRecorders: finder {PropFinder} "send checkRecorders to all children" myO checkRecorders: finder with: self sensorCrum! {void} checkTrailBlazer: blazer {TrailBlazer} myO checkTrailBlazer: blazer! {void} delayedStoreMatching: finder {PropFinder} with: fossil {RecorderFossil} with: recorder {ResultRecorder} with: hCrumCache {HashSetCache of: HistoryCrum} myO delayedStoreMatching: finder with: fossil with: recorder with: hCrumCache! {TrailBlazer | NULL} fetchTrailBlazer ^myO fetchTrailBlazer! {void} storeRecordingAgents: recorder {RecorderFossil} with: agenda {Agenda} myO storeRecordingAgents: recorder with: agenda! {void} triggerDetector: detect {FeFillRangeDetector} self sensorCrum isPartial ifTrue: [myO triggerDetector: detect] ifFalse: [detect rangeFilled: self asFeEdition]! {BooleanVar} updateBCrumTo: newBCrum {BertCrum} "My bertCrum must not be leafward of newBCrum. Thus it must be LE to newCrum. Otherwise correct it and recur." (super updateBCrumTo: newBCrum) ifTrue: [myO updateBCrumTo: newBCrum. ^true]. ^false! ! !DspLoaf methodsFor: 'create'! create: loaf {Loaf} with: dsp {Dsp} super create: NULL with: loaf sensorCrum. myO _ loaf. myDsp _ dsp. "Connect the HTrees." self newShepherd. myO addOParent: self.! ! !DspLoaf methodsFor: 'smalltalk:'! crums ^ Array with: myO! {BooleanVar} testChild: child {Loaf} "Return true if child is a child. Used for debugging." ^myO isEqual: child! {BooleanVar} testHChild: child {HistoryCrum} "Return true if child is a child. Used for debugging." ^myO hCrum == child! ! !DspLoaf methodsFor: 'protected: delete'! {void} dismantle DiskManager consistent: 3 with: [(Heaper isConstructed: myO) ifTrue: [myO removeOParent: self]. super dismantle]! ! !DspLoaf methodsFor: 'testing'! {UInt32} contentsHash ^(super contentsHash bitXor: myDsp hashForEqual) bitXor: myO hashForEqual! ! !DspLoaf methodsFor: 'smalltalk: passe'! {void} wait: sensor {XnSensor} self passe! ! !DspLoaf methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myDsp _ receiver receiveHeaper. myO _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myDsp. xmtr sendHeaper: myO.! !InnerLoaf subclass: #SplitLoaf instanceVariableNames: ' mySplit {XnRegion} myIn {Loaf} myOut {Loaf}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Ents'! (SplitLoaf getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(MAY.BECOME.ANY.SUBCLASS.OF OExpandingLoaf ); add: #COPY; add: #SHEPHERD.ANCESTOR; add: #LOCKED; add: #NOT.A.TYPE; yourself)! !SplitLoaf methodsFor: 'accessing'! {Mapping} compare: trace {TracePosition} with: region {XnRegion} "return a mapping from my data to corresponding stuff in the given trace" ^(myIn compare: trace with: (region intersect: mySplit)) combine: (myOut compare: trace with: (region minus: mySplit))! {IntegerVar} count ^myIn count + myOut count! {XnRegion} domain ^myIn domain unionWith: myOut domain! {FeRangeElement | NULL} fetch: key {Position} with: edition {BeEdition} with: globalKey {Position} "Look up the range element for the key. If it is embedded within a virtual structure, then make a virtual range element using the edition and globalKey." (mySplit hasMember: key) ifTrue: [^myIn fetch: key with: edition with: globalKey] ifFalse: [^myOut fetch: key with: edition with: globalKey]! {OExpandingLoaf} fetchBottomAt: key {Position} "Return the bottom-most Loaf. Used to get the owner and such of a position." self thingToDo. "This should be splaying!!" (mySplit hasMember: key) ifTrue: [^myIn fetchBottomAt: key] ifFalse: [^myOut fetchBottomAt: key]! {BeRangeElement} getBe: key {Position} "Get or Make the BeRangeElement at the location." self thingToDo. "This should be splaying!!" (mySplit hasMember: key) ifTrue: [^myIn getBe: key] ifFalse: [^myOut getBe: key]! {Loaf} inPart "This effectively copies the region represented by my distinction." ^myIn! {BooleanVar} isLeaf ^false! {Loaf} outPart "This is used by the splay algorithms." ^myOut! {XnRegion} rangeOwners: positions {XnRegion | NULL} | result {XnRegion} | positions == NULL ifTrue: [^(myIn rangeOwners: NULL) unionWith: (myIn rangeOwners: NULL)]. result _ IDSpace global emptyRegion. (mySplit intersects: positions) ifTrue: [result _ myIn rangeOwners: positions]. (mySplit complement intersects: positions) ifTrue: [result _ (myIn rangeOwners: positions) unionWith: result]. ^result! {OrglRoot} setAllOwners: owner {ID} "Recur assigning owners. Return the portion of the o-tree that couldn't be assigned." | in {OrglRoot} out {OrglRoot} | in _ myIn setAllOwners: owner. out _ myOut setAllOwners: owner. in isEmpty ifTrue: [^out]. out isEmpty ifTrue: [^in]. ((in cast: ActualOrglRoot) fullcrum == myIn and: [(out cast: ActualOrglRoot) fullcrum == myOut]) ifTrue: [^ActualOrglRoot make: self with: (in simpleDomain simpleUnion: out simpleDomain)]. ^(in cast: ActualOrglRoot) makeNew: mySplit with: (in cast: ActualOrglRoot) with: (out cast: ActualOrglRoot)! {XnRegion} usedDomain ^myIn usedDomain unionWith: myOut usedDomain! ! !SplitLoaf methodsFor: 'operations'! {Stepper} bundleStepper: region {XnRegion} with: order {OrderSpec} with: globalDsp {Dsp} "Return a stepper of bundles according to the order." | local {XnRegion} in {Stepper} out {Stepper} | local _ globalDsp inverseOfAll: region. in _ out _ NULL. (mySplit intersects: local) ifTrue: [in _ myIn bundleStepper: region with: order with: globalDsp]. (mySplit complement intersects: local) ifTrue: [out _ myOut bundleStepper: region with: order with: globalDsp]. in == NULL ifTrue: [out == NULL ifTrue: [^Stepper emptyStepper] ifFalse: [^out]] ifFalse: [out == NULL ifTrue: [^in] ifFalse: [^MergeBundlesStepper make: in with: out with: order]]! {OrglRoot} combine: another {ActualOrglRoot} with: limitRegion {XnRegion} with: globalDsp {Dsp} "Break another into pieces according to mySplit, and combine the corresponding pieces with my children transformed to global coordinates. Combine the two non-overlapping results." | newIn {ActualOrglRoot} newOut {ActualOrglRoot} hisIn {OrglRoot} hisOut {OrglRoot} globalIn {XnRegion} globalOut {XnRegion} | globalIn _ globalDsp ofAll: mySplit. globalOut _ globalIn complement. newIn _ ActualOrglRoot make: (myIn transformedBy: globalDsp) with: (limitRegion intersect: globalIn). newOut _ ActualOrglRoot make: (myOut transformedBy: globalDsp) with: (limitRegion intersect: globalOut). hisIn _ another copy: globalIn. hisOut _ another copy: globalOut. "Can this assume that the results don't overlap?" ^newIn makeNew: globalIn with: ((newIn combine: hisIn) cast: ActualOrglRoot) with: ((newOut combine: hisOut) cast: ActualOrglRoot)! {void} fill: keys {XnRegion} with: toArrange {Arrangement} with: toArray {PrimArray} with: globalDsp {Dsp} with: edition {BeEdition} "Make an FeRangeElement for each position." myIn fill: (keys intersect: mySplit) with: toArrange with: toArray with: globalDsp with: edition. myOut fill: (keys intersect: mySplit complement) with: toArrange with: toArray with: globalDsp with: edition.! {void} informTo: orgl {OrglRoot unused} "Copy the enclosure in orgl appropriate for this crum, then hand it down to the subCrums." self unimplemented. "orgl isKnownEmpty ifFalse: [myLeft informTo: ((orgl copy: leftWisp externalRegion) unTransformedBy: leftWisp dsp). myRight informTo: ((orgl copy: rightWisp externalRegion) unTransformedBy: rightWisp dsp)]"! {XnRegion} keysLabelled: label {BeLabel} "Just search for now." ^(myIn keysLabelled: label) unionWith: (myOut keysLabelled: label)! {XnRegion} sharedRegion: trace {TracePosition} with: limitRegion {XnRegion} "Return a region describing the stuff I share with the orgl under trace." (self hCrum inTrace: trace) ifTrue: [^self domain] ifFalse: [^(myIn sharedRegion: trace with: (limitRegion intersect: mySplit)) unionWith: (myOut sharedRegion: trace with: (limitRegion intersect: mySplit complement))]! ! !SplitLoaf methodsFor: 'printing'! {void} printOn: aStream {ostream reference} [myIn == nil ifTrue: [aStream << self getCategory name << '(nil)'. ^VOID]] smalltalkOnly. aStream << '(' << mySplit << ', ' << myIn << ', ' << myOut << ')'! ! !SplitLoaf methodsFor: 'create'! create: split {XnRegion} with: inLoaf {Loaf} with: outLoaf {Loaf} super create: NULL with: ((inLoaf sensorCrum computeJoin: outLoaf sensorCrum) cast: SensorCrum). myIn _ inLoaf. myOut _ outLoaf. mySplit _ split. "Connect the HTrees." self newShepherd. myIn addOParent: self. myOut addOParent: self.! create: split {XnRegion} with: inLoaf {Loaf} with: outLoaf {Loaf} with: hcrum {HUpperCrum} super create: hcrum with: ((inLoaf sensorCrum computeJoin: outLoaf sensorCrum) cast: SensorCrum). myIn _ inLoaf. myOut _ outLoaf. mySplit _ split. "Connect the HTrees." self newShepherd. myIn addOParent: self. myOut addOParent: self.! create: split {XnRegion} with: inLoaf {Loaf} with: outLoaf {Loaf} with: hcrum {HUpperCrum} with: hash {UInt32} super create: hash with: hcrum with: ((inLoaf sensorCrum computeJoin: outLoaf sensorCrum) cast: SensorCrum). myIn _ inLoaf. myOut _ outLoaf. mySplit _ split. "Connect the HTrees." self newShepherd. myIn addOParent: self. myOut addOParent: self.! create: split {XnRegion} with: inLoaf {Loaf} with: outLoaf {Loaf} with: hcrum {HUpperCrum} with: hash {UInt32} with: info {FlockInfo} "Special constructor for becoming this class" super create: hash with: hcrum with: ((inLoaf sensorCrum computeJoin: outLoaf sensorCrum) cast: SensorCrum). myIn _ inLoaf. myOut _ outLoaf. mySplit _ split. "Connect the HTrees." self flockInfo: info. myIn addOParent: self. myOut addOParent: self. self diskUpdate! ! !SplitLoaf methodsFor: 'smalltalk:'! crums ^((mySplit respondsTo: #isBoundedAbove) and: [mySplit isBoundedAbove]) ifTrue: [Array with: myIn with: myOut] ifFalse: [Array with: myOut with: myIn]! displayString ^'<', mySplit displayString, '>'! {BooleanVar} testChild: child {Loaf} "Return true if child is a child. Used for debugging." ^(myIn isEqual: child) or: [myOut isEqual: child]! {BooleanVar} testHChild: child {HistoryCrum} "Return true if child is a child. Used for debugging." ^(myIn hCrum == child) or: [myOut hCrum == child]! ! !SplitLoaf methodsFor: 'backfollow'! {void} addOParent: oparent {OPart} "add oparent to the set of upward pointers and update the bertCrums in southern children." | bCrum {BertCrum} newBCrum {BertCrum} | bCrum _ self hCrum bertCrum. super addOParent: oparent. "My bertCrum may have been changed by the last operation." newBCrum _ self hCrum bertCrum. (bCrum isLE: newBCrum) not ifTrue: [myIn updateBCrumTo: newBCrum. myOut updateBCrumTo: newBCrum] ifFalse: [(newBCrum isLE: bCrum) assert: 'unrelated bertCrums. Call dean!!']! {XnRegion} attachTrailBlazer: blazer {TrailBlazer} ^(myIn attachTrailBlazer: blazer) unionWith: (myOut attachTrailBlazer: blazer)! {void} checkChildRecorders: finder {PropFinder} myIn checkRecorders: finder with: self sensorCrum. myOut checkRecorders: finder with: self sensorCrum! {void} checkTrailBlazer: blazer {TrailBlazer} myIn checkTrailBlazer: blazer. myOut checkTrailBlazer: blazer.! {void} delayedStoreMatching: finder {PropFinder} with: fossil {RecorderFossil} with: recorder {ResultRecorder} with: hCrumCache {HashSetCache of: HistoryCrum} myIn delayedStoreMatching: finder with: fossil with: recorder with: hCrumCache. myOut delayedStoreMatching: finder with: fossil with: recorder with: hCrumCache! {TrailBlazer | NULL} fetchTrailBlazer | result {TrailBlazer | NULL} | result := myIn fetchTrailBlazer. result ~~ NULL ifTrue: [^result] ifFalse: [^myOut fetchTrailBlazer]! {void} storeRecordingAgents: recorder {RecorderFossil} with: agenda {Agenda} myIn storeRecordingAgents: recorder with: agenda. myOut storeRecordingAgents: recorder with: agenda! {void} triggerDetector: detect {FeFillRangeDetector} self sensorCrum isPartial ifTrue: [myIn triggerDetector: detect. myOut triggerDetector: detect] ifFalse: ["there is no partiality below me so I can just trigger it with everything" detect rangeFilled: self asFeEdition]! {BooleanVar} updateBCrumTo: newBCrum {BertCrum} "My bertCrum must not be leafward of newBCrum. Thus it must be LE to newCrum. Otherwise correct it and recur." (super updateBCrumTo: newBCrum) ifTrue: [myIn updateBCrumTo: newBCrum. myOut updateBCrumTo: newBCrum. ^true]. ^false! ! !SplitLoaf methodsFor: 'protected: splay'! {Int8} actualSplay: region {XnRegion} with: limitRegion {XnRegion} "Make each child completely contained or completely outside the region. Return the number of children completely in the region. The transformation table follows: # in out return operation rearrange 1| 0 0 0 none none 2| 0 1 1 swap #4 (A (B* C)) -> (B* (A C)) 3| 0 2 1 swap #7 (A B*) -> (B* A) 4| 1 0 1 rotateRight ((A* B) C) -> (A* (B C)) 5| 1 1 1 interleave ((A* B) (C* D)) -> ((A* C*) (B D)) 6| 1 2 1 swap #8 ((A* B) C*) -> ((A* C*) B) 7| 2 0 1 none none 8| 2 1 1 rotateLeft (A* (B* C)) -> ((A* B*) C) 9| 2 2 2 none none" | in {UInt8} out {UInt8} | "For each child, compute the number of grandchildren completely contained in region." in _ myIn splay: region with: (mySplit intersect: limitRegion). out _ myOut splay: region with: (mySplit complement intersect: limitRegion). DiskManager consistent: 19 with: ["Swap the out and in sides if necessary to reduce the number of cases." out > in ifTrue: [| cnt {UInt8} | cnt _ out. out _ in. in _ cnt. self swapChildren]. "The hard cases are when a child is partially contained (in or out = 1). For those cases, construct the two new children, then install them." (in == 1 or: [out == 1]) ifTrue: [| newIn {Loaf} newOut {Loaf} | out == Int0 ifTrue: [newIn _ (myIn cast: InnerLoaf) inPart. newOut _ self makeNew: (myIn cast: InnerLoaf) outPart with: myOut] ifFalse: [in == 2 ifTrue: [newIn _ self makeNew: myIn with: (myOut cast: InnerLoaf) inPart. newOut _ (myOut cast: InnerLoaf) outPart] ifFalse: [newIn _ self makeNew: (myIn cast: InnerLoaf) inPart with: (myOut cast: InnerLoaf) inPart. newOut _ self makeNew: (myIn cast: InnerLoaf) outPart with: (myOut cast: InnerLoaf) outPart]]. "The splayed region represents the newDistinction for me in the split cases." self install: newIn with: newOut with: region. ^1] ifFalse: ["The non-rotating cases: ^in==0 ifTrue: [0] ifFalse: [ out==0 ifTrue: [1] ifFalse: [2] ]" "The 1 case here should change mySplit to the incoming one." ^in + out // 2]]! ! !SplitLoaf methodsFor: 'private: splay'! {void} install: newIn {Loaf} with: newOut {Loaf} with: newSplit {XnRegion} "Install new in and out children at the same time. This will need to be in a critical section. Add me as parent to the new loaves first in case the only ent reference to the new loaf is through one of my children (which might delete it if I'm *their* last reference)." newIn addOParent: self. newOut addOParent: self. myIn removeOParent: self. myIn _ newIn. myOut removeOParent: self. myOut _ newOut. mySplit _ newSplit. self thingToDo. "This shouldn't update the disk if the swapChildren already did." self diskUpdate! {Loaf} makeNew: newIn {Loaf} with: newOut {Loaf} "Make a new crum to replace some existing crums during a splay operation. The new crum must have the same trace as me to guarantee the hTree property. Optimization: look at parents of the new loaves to find a pre-existing parent with the same trace and wisps. This will coalesce the shearing that splaying causes." "The new loaf is made from pieces of me, so they are distinguished by my split." ^InnerLoaf make: mySplit with: newIn with: newOut with: (HUpperCrum make: (self hCrum cast: HUpperCrum))! {void} swapChildren "This is a support for the splay routine. Swapping the children reduces the number of cases. This way, if this crum is partially in a region being splayed, the part contained in the region resides in the left slot." | loaf {Loaf} | mySplit _ mySplit complement. loaf _ myIn. myIn _ myOut. myOut _ loaf. self thingToDo. "Swapping may be expensive if it's unnecessary. Check more cases in the splay routine." self diskUpdate! ! !SplitLoaf methodsFor: 'protected: delete'! {void} dismantle DiskManager consistent: 4 with: [(Heaper isConstructed: myIn) ifTrue: [myIn removeOParent: self]. (Heaper isConstructed: myOut) ifTrue: [myOut removeOParent: self]. super dismantle]! ! !SplitLoaf methodsFor: 'testing'! {UInt32} contentsHash ^((super contentsHash bitXor: mySplit hashForEqual) bitXor: myIn hashForEqual) bitXor: myOut hashForEqual! ! !SplitLoaf methodsFor: 'smalltalk: passe'! {void} wait: sensor {XnSensor} self passe! ! !SplitLoaf methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. mySplit _ receiver receiveHeaper. myIn _ receiver receiveHeaper. myOut _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: mySplit. xmtr sendHeaper: myIn. xmtr sendHeaper: myOut.! !Loaf subclass: #OExpandingLoaf instanceVariableNames: 'myRegion {XnRegion}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Ents'! OExpandingLoaf comment: ' NOT.A.TYPE'! (OExpandingLoaf getOrMakeCxxClassDescription) attributes: ((Set new) add: #COPY; add: #DEFERRED; add: #SHEPHERD.ANCESTOR; add: #DEFERRED.LOCKED; add: #(MAY.BECOME SplitLoaf ); yourself)! !OExpandingLoaf methodsFor: 'operations'! {Stepper} bundleStepper: region {XnRegion} with: order {OrderSpec} with: globalDsp {Dsp} "Return a stepper of bundles according to the order." self subclassResponsibility! {OrglRoot} combine: another {ActualOrglRoot} with: limitRegion {XnRegion unused} with: globalDsp {Dsp} "Accumulate dsp downward." | myGlobalRegion {XnRegion} result {ActualOrglRoot} him {OrglRoot} | myGlobalRegion _ (globalDsp ofAll: myRegion). (another copy: myGlobalRegion) isEmpty ifFalse: [Heaper BLAST: #IntersectingCombine]. result _ ActualOrglRoot make: (self transformedBy: globalDsp) with: myGlobalRegion. him _ another. [ScruSet] USES. myGlobalRegion distinctions stepper forEach: [:split {XnRegion} | | hisOut {OrglRoot} | hisOut _ him copy: split complement. hisOut isEmpty ifFalse: [result _ result makeNew: split with: result with: (hisOut cast: ActualOrglRoot). him _ another copy: split]]. him isEmpty ifFalse: [Heaper BLAST: #CombineLoopFailed]. ^result! {void} informTo: orgl {OrglRoot unused} self unimplemented! {Boolean} isPartial ^false! {UInt8} splay: region {XnRegion} with: limitRegion {XnRegion} "Make each child completely contained or completely outside the region. Return the number of children completely in the region. Handle the containment cases using myRegion." (myRegion isSubsetOf: region) ifTrue: [^2] ifFalse: [(myRegion intersects: region) ifTrue: [^self actualSplay: region with: limitRegion] ifFalse: [^Int0]]! ! !OExpandingLoaf methodsFor: 'backfollow'! {XnRegion} attachTrailBlazer: blazer {TrailBlazer} self subclassResponsibility! {void} checkChildRecorders: finder {PropFinder} "send checkRecorders to all children"! {void} checkTrailBlazer: blazer {TrailBlazer} self subclassResponsibility! {void} delayedStoreMatching: finder {PropFinder} with: fossil {RecorderFossil} with: recorder {ResultRecorder} with: hCrumCache {HashSetCache of: HistoryCrum} "Default south-to-north turnaround point during 'now' part of backfollow (which is leafward, then rootward, in the H-tree, filtered by the Bert canopy). (Sometimes overridden). (OExpandingLoaf is the supercalss of all O-tree leaf types.)" self hCrum delayedStoreBackfollow: finder with: fossil with: recorder with: hCrumCache! {TrailBlazer | NULL} fetchTrailBlazer self subclassResponsibility! {void} storeRecordingAgents: recorder {RecorderFossil} with: agenda {Agenda} agenda registerItem: (self sensorCrum recordingAgent: recorder)! {void} triggerDetector: detect {FeFillRangeDetector} self subclassResponsibility! ! !OExpandingLoaf methodsFor: 'accessing'! {Mapping} compare: trace {TracePosition} with: region {XnRegion} "return a mapping from my data to corresponding stuff in the given trace" ^self hCrum mappingTo: trace with: (region coordinateSpace identityDsp restrict: region)! {IntegerVar} count ^myRegion count! {XnRegion} domain ^myRegion! {FeRangeElement | NULL} fetch: key {Position} with: edition {BeEdition} with: globalKey {Position} self subclassResponsibility! {OExpandingLoaf} fetchBottomAt: key {Position} "I'm at the bottom." ^self! {void} fill: keys {XnRegion} with: toArrange {Arrangement} with: toArray {PrimArray} with: globalDsp {Dsp} with: edition {BeEdition} "Fill an array with my contents" self subclassResponsibility! {BeRangeElement} getBe: key {Position} "Get or Make the BeRangeElement at the location." self subclassResponsibility! {XnRegion} keysLabelled: label {BeLabel} "This gets overridden by RegionLoaf." ^self domain coordinateSpace emptyRegion! {ID} owner "Return the owner of the atoms represented by the receiver." self subclassResponsibility! {XnRegion} rangeOwners: positions {XnRegion | NULL} (positions == NULL or: [myRegion intersects: positions]) ifTrue: [^self owner asRegion] ifFalse: [^self owner coordinateSpace emptyRegion]! {OrglRoot} setAllOwners: owner {ID} "If the CurrentKeyMaster includes the owner of this loaf then change the owner and return NULL else just return self." self subclassResponsibility! {XnRegion} sharedRegion: trace {TracePosition} with: limitRegion {XnRegion unused} "Return a region describing the stuff that can backfollow to trace." (self hCrum inTrace: trace) ifTrue: [^myRegion] ifFalse: [^myRegion coordinateSpace emptyRegion]! {PrimSpec} spec "Return the PrimSpec that describes the representation of the data." self subclassResponsibility! {XnRegion} usedDomain self subclassResponsibility! ! !OExpandingLoaf methodsFor: 'printing'! {void} printOn: aStream {ostream reference} aStream << self getCategory name << '(' << myRegion << ')'! ! !OExpandingLoaf methodsFor: 'protected: splay'! {Int8} actualSplay: region {XnRegion unused} with: limitRegion {XnRegion unused} "Return an Inner loaf which is an expansion of me. The area in the region must go into the leftCrum of my substitute, or the splay algorithm will fail!! implementations must call diskUpdate." self subclassResponsibility! ! !OExpandingLoaf methodsFor: 'create'! create: region {XnRegion} super create: NULL with: NULL. region isEmpty not assert. myRegion _ region.! create: region {XnRegion} with: hcrum {HUpperCrum | NULL} with: sensor {SensorCrum} super create: hcrum with: sensor. region isEmpty not assert. myRegion _ region.! create: hash {UInt32} with: region {XnRegion} with: hcrum {HUpperCrum} with: sensor {SensorCrum} super create: hash with: hcrum with: sensor. region isEmpty not assert. myRegion _ region.! ! !OExpandingLoaf methodsFor: 'testing'! {UInt32} contentsHash ^super contentsHash bitXor: myRegion hashForEqual! ! !OExpandingLoaf methodsFor: 'smalltalk:'! crums ^#()! displayString ^'"' , myRegion printString , '"'! inspect self basicInspect! ! !OExpandingLoaf methodsFor: 'smalltalk: passe'! {void} wait: sensor {XnSensor} self passe! ! !OExpandingLoaf methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myRegion _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myRegion.! !OExpandingLoaf subclass: #OPartialLoaf instanceVariableNames: ' myOwner {ID} myTrailBlazer {TrailBlazer | NULL}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Ents'! (OPartialLoaf getOrMakeCxxClassDescription) attributes: ((Set new) add: #NOT.A.TYPE; add: #CONCRETE; add: #COPY; add: #SHEPHERD.ANCESTOR; add: #LOCKED; add: #(MAY.BECOME RegionLoaf ); yourself)! !OPartialLoaf methodsFor: 'accessing'! {FeRangeElement | NULL} fetch: key {Position} with: edition {BeEdition} with: globalKey {Position} "Make a virtual PlaceHolder." (self domain hasMember: key) ifTrue: [^FePlaceHolder fake: edition with: globalKey] ifFalse: [^NULL]! {BeRangeElement} getBe: key {Position} "Get or make the BeRangeElement at the location." "My region had better be just onto the key. become a RegionLoaf onto a new BePlaceHolder" | element {BeRangeElement} domain {XnRegion} hcrum {HUpperCrum} hash {UInt32} info {FlockInfo}| domain _ key asRegion. (self domain isEqual: domain) ifFalse: [Heaper BLAST: #NotInTable]. hcrum _ self hCrum cast: HUpperCrum. hash _ self hashForEqual. info _ self fetchInfo. DiskManager consistent: [self sensorCrum removePointer: self. InitialOwner fluidBind: self owner during: [[Ent] USES. CurrentTrace fluidBind: self hCrum hCut during: [CurrentBertCrum fluidBind: BertCrum make during: [element _ BePlaceHolder create: myTrailBlazer. myTrailBlazer ~~ NULL ifTrue: [myTrailBlazer removeReference: self. myTrailBlazer := NULL]]]]. (RegionLoaf new.Become: self) create: domain with: element with: hcrum with: hash with: info]. ^element! {ID} owner "Return the owner of the atoms represented by the receiver." ^myOwner! {PrimSpec} spec "Return the PrimSpec that describes the representation of the data." self unimplemented. ^PrimSpec pointer! {XnRegion} usedDomain ^self domain coordinateSpace emptyRegion! ! !OPartialLoaf methodsFor: 'operations'! {Stepper} bundleStepper: region {XnRegion} with: order {OrderSpec} with: globalDsp {Dsp} "Return a stepper of bundles according to the order." | bundleRegion {XnRegion} | bundleRegion _ region intersect: (globalDsp ofAll: self domain). bundleRegion isEmpty ifTrue: [^Stepper emptyStepper]. ^Stepper itemStepper: (FePlaceHolderBundle make: bundleRegion)! {void} fill: keys {XnRegion} with: toArrange {Arrangement} with: toArray {PrimArray} with: dsp {Dsp} with: edition {BeEdition} "Make an FeRangeElement for each position." (keys intersect: self domain) stepper forEach: [:key {Position} | | globalKey {Position} | globalKey _ dsp of: key. toArray at: (toArrange indexOf: globalKey) DOTasLong storeValue: (FePlaceHolder fake: edition with: globalKey)]! {void} informTo: orgl {OrglRoot unused} self unimplemented! {Boolean} isPartial "Partial crums are always partial." ^true! {OrglRoot} setAllOwners: owner {ID} "If the CurrentKeyMaster includes the owner of this loaf then change the owner and return NULL else just return self." (CurrentKeyMaster fluidGet hasAuthority: myOwner) ifTrue: [myOwner _ owner. ^OrglRoot make: self domain coordinateSpace] ifFalse: [^ActualOrglRoot make: self with: self domain]! ! !OPartialLoaf methodsFor: 'protected: splay'! {Int8} actualSoftSplay: region {XnRegion} with: limitRegion {XnRegion unused} "Don't expand me in place. Just move it closer to the top." ^2! {Int8} actualSplay: region {XnRegion} with: limitRegion {XnRegion unused} "Expand my partial tree in place. The area in the region must go into the leftCrum of my substitute, or the splay algorithm will fail!!" | crums {Pair of: SensorCrum} tmp1 {Loaf} tmp2 {Loaf} | crums _ self sensorCrum expand. DiskManager consistent: 3 with: [tmp1 _ OPartialLoaf create: (self domain intersect: region) with: (HUpperCrum make: (self hCrum cast: HUpperCrum)) with: (crums left cast: SensorCrum) with: myOwner with: myTrailBlazer]. DiskManager consistent: 3 with: [tmp2 _ OPartialLoaf create: (self domain intersect: region complement) with: (HUpperCrum make: (self hCrum cast: HUpperCrum)) with: (crums right cast: SensorCrum) with: myOwner with: myTrailBlazer]. myTrailBlazer ~~ NULL ifTrue: [DiskManager consistent: 1 with: [myTrailBlazer addReference: tmp1. myTrailBlazer addReference: tmp2. myTrailBlazer removeReference: self]]. DiskManager consistent: 5 with: [| hcrum {HUpperCrum} hash {UInt32} info {FlockInfo} oldSensorCrum {CanopyCrum} | hcrum _ self hCrum cast: HUpperCrum. hash _ self hashForEqual. oldSensorCrum _ self sensorCrum. info _ self fetchInfo. (SplitLoaf new.Become: self) create: region with: tmp1 with: tmp2 with: hcrum with: hash with: info. "The new SplitLoaf will add itself." oldSensorCrum removePointer: self]. ^1! ! !OPartialLoaf methodsFor: 'create'! create: region {XnRegion} super create: region. myOwner _ InitialOwner fluidFetch. myTrailBlazer := NULL. self newShepherd! create: region {XnRegion} with: hcrum {HUpperCrum} with: scrum {SensorCrum} super create: region with: hcrum with: scrum. myOwner _ InitialOwner fluidFetch. myTrailBlazer := NULL. self newShepherd! create: region {XnRegion} with: hcrum {HUpperCrum} with: scrum {SensorCrum} with: owner {ID} with: blazer {TrailBlazer | NULL} super create: region with: hcrum with: scrum. myOwner := owner. myTrailBlazer := blazer. self newShepherd! ! !OPartialLoaf methodsFor: 'protected: delete'! {void} dismantle DiskManager consistent: 4 with: [(Heaper isConstructed: myTrailBlazer) ifTrue: [myTrailBlazer removeReference: self]. super dismantle]! ! !OPartialLoaf methodsFor: 'smalltalk: passe'! {void} inform: key {Position} with: element {BeRangeElement} with: trace {TracePosition} "inform a piece of partiality" self passe. [| in {XnRegion} impartial {Loaf} hcrum {HUpperCrum} hash {UInt32} info {FlockInfo} sensors {ImmuSet} | (self domain hasMember: key) ifFalse: [Heaper BLAST: #NotInTable]. (self hCrum hCut isEqual: trace) ifFalse: [Heaper BLAST: #CantInform]. in _ key asRegion. hcrum _ self hCrum cast: HUpperCrum. hash _ self hashForEqual. info _ self fetchInfo. Someone shouldImplement. self unimplemented. "used to be detectors. sensors _ mySensors." (in isEqual: self domain) ifTrue: [impartial _ self. self sensorCrum removePointer: self. (RegionLoaf new.Become: self) create: in with: element with: (HUpperCrum make: hcrum) with: hash with: info] ifFalse: [ | partial {Loaf} | impartial _ Loaf make.Region: in with: (CurrentGrandMap fluidGet carrier: element). partial _ OPartialLoaf make: (self domain minus: in) with: (HUpperCrum make: hcrum) with: self sensorCrum. self sensorCrum removePointer: self. (SplitLoaf new.Become: self) create: in with: impartial with: partial with: hcrum with: hash with: info]. "self flockInfo: info." Dean shouldImplement. "sensors stepper forEach: [ :sensor {XnSensor} | sensor ring: impartial]"] smalltalkOnly "so we can look at the old code"! {void} wait: sensor {XnSensor} self passe! ! !OPartialLoaf methodsFor: 'backfollow'! {XnRegion} attachTrailBlazer: blazer {TrailBlazer} DiskManager consistent: 2 with: [myTrailBlazer ~~ NULL ifTrue: [myTrailBlazer isAlive ifTrue: [Heaper BLAST: #FatalError] ifFalse: [myTrailBlazer removeReference: self]]. myTrailBlazer := blazer. blazer addReference: self. self diskUpdate]. ^self domain! {void} checkTrailBlazer: blazer {TrailBlazer} (myTrailBlazer ~~ NULL and: [myTrailBlazer isEqual: blazer]) ifFalse: [Heaper BLAST: #InvalidTrail].! {TrailBlazer | NULL} fetchTrailBlazer (myTrailBlazer == NULL or: [myTrailBlazer isAlive]) ifTrue: [^myTrailBlazer]. "it was not successfully attached, so clean it up" DiskManager consistent: 2 with: [myTrailBlazer removeReference: self. myTrailBlazer := NULL. self diskUpdate. ^NULL]! {void} triggerDetector: detect {FeFillRangeDetector} "do nothing"! ! !OPartialLoaf methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myOwner _ receiver receiveHeaper. myTrailBlazer _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myOwner. xmtr sendHeaper: myTrailBlazer.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! OPartialLoaf class instanceVariableNames: ''! (OPartialLoaf getOrMakeCxxClassDescription) attributes: ((Set new) add: #NOT.A.TYPE; add: #CONCRETE; add: #COPY; add: #SHEPHERD.ANCESTOR; add: #LOCKED; add: #(MAY.BECOME RegionLoaf ); yourself)! !OPartialLoaf class methodsFor: 'smalltalk: passe'! {Loaf} make: region {XnRegion} with: hcrum {HUpperCrum} with: scrum {SensorCrum} self passe! !OExpandingLoaf subclass: #OVirtualLoaf instanceVariableNames: ' myOwner {ID} myData {SharedData}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Ents'! (OVirtualLoaf getOrMakeCxxClassDescription) attributes: ((Set new) add: #COPY; add: #SHEPHERD.ANCESTOR; add: #LOCKED; add: #NOT.A.TYPE; add: #CONCRETE; yourself)! !OVirtualLoaf methodsFor: 'accessing'! {FeRangeElement | NULL} fetch: key {Position} with: edition {BeEdition} with: globalKey {Position} "Make a virtual DataHolder." (self domain hasMember: key) ifTrue: [^FeDataHolder fake: ((myData fetch: key) cast: PrimValue) with: globalKey with: edition] ifFalse: [^NULL]! {BeRangeElement} getBe: key {Position} "Get or make the BeRangeElement at the location." "My region had better be just onto the key. become a RegionLoaf onto a new BeDataHolder containing the data extracted from my SharedData object." | element {BeRangeElement} domain {XnRegion} hcrum {HUpperCrum} hash {UInt32} info {FlockInfo}| domain _ key asRegion. (self domain isEqual: domain) ifFalse: [Heaper BLAST: #NotInTable]. hcrum _ self hCrum cast: HUpperCrum. hash _ self hashForEqual. info _ self fetchInfo. DiskManager consistent: [| oldSensorCrum {CanopyCrum} | oldSensorCrum _ self sensorCrum. [Ent] USES. InitialOwner fluidBind: self owner during: [CurrentTrace fluidBind: self hCrum hCut during: [CurrentBertCrum fluidBind: BertCrum make during: [element _ BeDataHolder create: ((myData fetch: key) cast: PrimValue)]]]. (RegionLoaf new.Become: self) create: domain with: element with: hcrum with: hash with: info. oldSensorCrum removePointer: self]. ^element! {ID} owner "Return the owner of the atoms represented by the receiver." ^myOwner! {PrimSpec} spec "Return the primSpec for my data." ^myData spec! {XnRegion} usedDomain ^self domain! ! !OVirtualLoaf methodsFor: 'operations'! {Stepper} bundleStepper: region {XnRegion} with: order {OrderSpec} with: globalDsp {Dsp} "Return a stepper of bundles according to the order." | bundleRegion {XnRegion} array {PrimArray} | bundleRegion _ region intersect: (globalDsp ofAll: self domain). bundleRegion isEmpty ifTrue: [^Stepper emptyStepper]. array _ myData spec array: bundleRegion count DOTasLong. myData fill: bundleRegion with: (order arrange: bundleRegion) with: array with: globalDsp. ^Stepper itemStepper: (FeArrayBundle make: bundleRegion with: array with: order)! {void} fill: keys {XnRegion} with: toArrange {Arrangement} with: toArray {PrimArray} with: dsp {Dsp} with: edition {BeEdition} myData fill: (keys intersect: self domain) with: toArrange with: toArray with: dsp! {void} informTo: orgl {OrglRoot unused} self unimplemented! {OrglRoot} setAllOwners: owner {ID} "If the CurrentKeyMaster includes the owner of this loaf then change the owner and return NULL else just return self." (CurrentKeyMaster fluidGet hasAuthority: myOwner) ifTrue: [myOwner _ owner. ^OrglRoot make: self domain coordinateSpace] ifFalse: [^ActualOrglRoot make: self with: self domain]! ! !OVirtualLoaf methodsFor: 'printing'! {void} printOn: aStream {ostream reference} aStream << self getCategory name << '(' << "(myData table subTable: self domain) <<" ', ' << self hCrum hCut << ')'! ! !OVirtualLoaf methodsFor: 'protected: splay'! {Int8} actualSoftSplay: region {XnRegion} with: limitRegion {XnRegion unused} "Don't expand my virtual tree in place. Just move it closer to the top." ^2! {Int8} actualSplay: region {XnRegion} with: limitRegion {XnRegion unused} "Expand my partial tree in place. The area in the region must go into the leftCrum of my substitute, or the splay algorithm will fail!!" | crums {Pair of: SensorCrum} tmp1 {Loaf} tmp2 {Loaf} | crums _ self sensorCrum expand. InitialOwner fluidBind: self owner during: [DiskManager consistent: 3 with: [tmp1 _ OVirtualLoaf create: (self domain intersect: region) with: myData with: (HUpperCrum make: (self hCrum cast: HUpperCrum)) with: (crums left cast: SensorCrum)]. DiskManager consistent: 3 with: [tmp2 _ OVirtualLoaf create: (self domain intersect: region complement) with: myData with: (HUpperCrum make: (self hCrum cast: HUpperCrum)) with: (crums right cast: SensorCrum)]. DiskManager consistent: 5 with: [| hcrum {HUpperCrum} hash {UInt32} info {FlockInfo} oldSensorCrum {CanopyCrum} | hcrum _ self hCrum cast: HUpperCrum. hash _ self hashForEqual. oldSensorCrum _ self sensorCrum. info _ self fetchInfo. (SplitLoaf new.Become: self) create: region with: tmp1 with: tmp2 with: hcrum with: hash with: info. "The new SplitLoaf will add itself." oldSensorCrum removePointer: self]]. ^1! ! !OVirtualLoaf methodsFor: 'create'! create: region {XnRegion} with: data {SharedData} super create: region. myData _ data. myOwner _ InitialOwner fluidFetch. self newShepherd! create: region {XnRegion} with: data {SharedData} with: hcrum {HUpperCrum} with: scrum {SensorCrum} super create: region with: hcrum with: scrum. myData _ data. myOwner _ InitialOwner fluidFetch. self newShepherd! ! !OVirtualLoaf methodsFor: 'testing'! {UInt32} contentsHash ^super contentsHash bitXor: myData contentsHash! ! !OVirtualLoaf methodsFor: 'smalltalk:'! showOn: oo oo << myData! ! !OVirtualLoaf methodsFor: 'smalltalk: passe'! {void} wait: sensor {XnSensor} self passe! ! !OVirtualLoaf methodsFor: 'backfollow'! {XnRegion} attachTrailBlazer: blazer {TrailBlazer} ^self domain coordinateSpace emptyRegion! {void} checkTrailBlazer: blazer {TrailBlazer} "it's OK"! {TrailBlazer | NULL} fetchTrailBlazer ^NULL! {void} triggerDetector: detect {FeFillRangeDetector} detect rangeFilled: self asFeEdition! ! !OVirtualLoaf methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myOwner _ receiver receiveHeaper. myData _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myOwner. xmtr sendHeaper: myData.! !OExpandingLoaf subclass: #RegionLoaf instanceVariableNames: ' myRangeElement {BeRangeElement} myLabel {BeLabel}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Ents'! (RegionLoaf getOrMakeCxxClassDescription) attributes: ((Set new) add: #COPY; add: #SHEPHERD.ANCESTOR; add: #LOCKED; add: #NOT.A.TYPE; add: #CONCRETE; yourself)! !RegionLoaf methodsFor: 'accessing'! {Mapping} compare: trace {TracePosition} with: region {XnRegion} "return a mapping from my data to corresponding stuff in the given trace" ^myRangeElement mappingTo: trace with: (region coordinateSpace identityDsp restrict: region)! {FeRangeElement | NULL} fetch: key {Position} with: edition {BeEdition} with: globalKey {Position} "Make a virtual DataHolder." (self domain hasMember: key) ifTrue: [^myRangeElement makeFe: myLabel] ifFalse: [^NULL]! {void} fill: keys {XnRegion} with: toArrange {Arrangement} with: toArray {PrimArray} with: dsp {Dsp} with: edition {BeEdition} "Make an FeRangeElement for each position." (keys intersect: self domain) stepper forEach: [:key {Position} | | globalKey {Position} fe {FeRangeElement} | globalKey _ dsp of: key. fe := myRangeElement makeFe: myLabel. toArray at: (toArrange indexOf: globalKey) DOTasLong storeValue: fe]! {void} forwardTo: rangeElement {BeRangeElement} DiskManager consistent: [rangeElement addOParent: self. myRangeElement removeOParent: self. myRangeElement _ rangeElement. self diskUpdate]. Ravi thingToDo. "Is there a lazier way to make the FeEdition?" self hCrum bertCrum isSensorWaiting ifTrue: [self hCrum ringDetectors: self asFeEdition]! {BeRangeElement} getBe: key {Position} "If I'm here it must be non-virtual." (self domain hasMember: key) ifTrue: [^myRangeElement] ifFalse: [Heaper BLAST: #NotInTable. ^NULL]! {XnRegion} keysLabelled: label {BeLabel} "The keys in this Edition at which there are Editions with the given label." (myLabel ~~ NULL and: [myLabel isEqual: label]) ifTrue: [^self domain] ifFalse: [^self domain coordinateSpace emptyRegion]! {Mapping} mappingTo: trace {TracePosition} with: initial {Mapping} "return the mapping into the domain space of the given trace" ^self hCrum mappingTo: trace with: ((Mapping make: initial coordinateSpace with: self domain) restrict: initial domain)! {ID} owner "Return the owner of the atoms represented by the receiver." ^myRangeElement owner! {XnRegion} sharedRegion: trace {TracePosition} with: limitRegion {XnRegion unused} "Return a region describing the stuff that can backfollow to trace. Redefine this to pass down to my hRoot." (myRangeElement inTrace: trace) ifTrue: [^self domain] ifFalse: [^self domain coordinateSpace emptyRegion]! {PrimSpec} spec "Return the PrimSpec that describes the representation of the data." self unimplemented. ^PrimSpec pointer! {XnRegion} usedDomain ^self domain! ! !RegionLoaf methodsFor: 'operations'! {Stepper} bundleStepper: region {XnRegion} with: order {OrderSpec} with: globalDsp {Dsp} "Return a stepper of bundles according to the order." | bundleRegion {XnRegion} | bundleRegion _ region intersect: (globalDsp ofAll: self domain). bundleRegion isEmpty ifTrue: [^Stepper emptyStepper]. ^Stepper itemStepper: (FeElementBundle make: bundleRegion with: (myRangeElement makeFe: myLabel))! {void} informTo: orgl {OrglRoot unused} self unimplemented! {OrglRoot} setAllOwners: owner {ID} "If the CurrentKeyMaster includes the owner of this loaf then change the owner and return NULL else just return self." (CurrentKeyMaster fluidGet hasAuthority: myRangeElement owner) ifTrue: [myRangeElement setOwner: owner. ^OrglRoot make: self domain coordinateSpace] ifFalse: [^ActualOrglRoot make: self with: self domain]! ! !RegionLoaf methodsFor: 'printing'! {void} printOn: aStream {ostream reference} aStream << self getCategory name << '(' << self domain << ', ' << myRangeElement << ')'! ! !RegionLoaf methodsFor: 'protected: splay'! {Int8} actualSoftSplay: region {XnRegion} with: limitRegion {XnRegion unused} "Don't expand me in place. Just move it closer to the top." ^2! {Int8} actualSplay: region {XnRegion} with: limitRegion {XnRegion unused} "Expand my partial tree in place. The area in the region must go into the leftCrum of my substitute, or the splay algorithm will fail!!" | tmp1 {Loaf} tmp2 {Loaf} | DiskManager consistent: 4 with: [tmp1 _ RegionLoaf create: (self domain intersect: region) with: myLabel with: myRangeElement with: (HUpperCrum make: (self hCrum cast: HUpperCrum))]. DiskManager consistent: 4 with: [tmp2 _ RegionLoaf create: (self domain intersect: region complement) with: myLabel with: myRangeElement with: (HUpperCrum make: (self hCrum cast: HUpperCrum))]. DiskManager consistent: 4 with: [ | hcrum {HUpperCrum} hash {UInt32} info {FlockInfo} | hcrum _ self hCrum cast: HUpperCrum. hash _ self hashForEqual. info _ self fetchInfo. (SplitLoaf new.Become: self) create: region with: tmp1 with: tmp2 with: hcrum with: hash with: info]. ^1! ! !RegionLoaf methodsFor: 'create'! create: region {XnRegion} with: label {BeLabel | NULL} with: element {BeRangeElement} with: hcrum {HUpperCrum | NULL} super create: region with: hcrum with: element sensorCrum. myLabel _ label. myRangeElement _ element. self newShepherd. myRangeElement addOParent: self.! create: region {XnRegion} with: element {BeRangeElement} with: hcrum {HUpperCrum} with: hash {UInt32} with: info {FlockInfo} super create: hash with: region with: hcrum with: element sensorCrum. (element isKindOf: BeEdition) ifTrue: [Heaper BLAST: #EditionsRequireLabels]. myLabel _ NULL. self knownBug. "This doesn't deal with labels." self flockInfo: info. myRangeElement _ element. myRangeElement addOParent: self. self diskUpdate! ! !RegionLoaf methodsFor: 'backfollow'! {void} addOParent: oparent {OPart} "add oparent to the set of upward pointers and update the bertCrums my child." | bCrum {BertCrum} newBCrum {BertCrum} | bCrum _ self hCrum bertCrum. super addOParent: oparent. newBCrum _ self hCrum bertCrum. (bCrum isLE: newBCrum) not ifTrue: [myRangeElement updateBCrumTo: newBCrum]! {XnRegion} attachTrailBlazer: blazer {TrailBlazer} myRangeElement cast: BePlaceHolder into: [ :p | p attachTrailBlazer: blazer. ^self domain] others: [^self domain coordinateSpace emptyRegion]! {void} checkChildRecorders: finder {PropFinder} myRangeElement checkRecorders: finder with: self sensorCrum! {void} checkTrailBlazer: blazer {TrailBlazer} myRangeElement cast: BePlaceHolder into: [ :p | p checkTrailBlazer: blazer] others: ["OK"]! {void} delayedStoreMatching: finder {PropFinder} with: fossil {RecorderFossil} with: recorder {ResultRecorder} with: hCrumCache {HashSetCache of: HistoryCrum} "RegionLoaf is the one kind of o-leaf which actually shares range-element identity with other o-leafs. The range element identity is in myRangeElement rather than myself, so I override my super's version of this method to forward it south one more step to myRangeElement." recorder delayedStoreMatching: myRangeElement with: finder with: fossil with: hCrumCache! {TrailBlazer | NULL} fetchTrailBlazer myRangeElement cast: BePlaceHolder into: [ :p | ^p fetchTrailBlazer] others: [^NULL]! {void} storeRecordingAgents: recorder {RecorderFossil} with: agenda {Agenda} recorder storeRangeElementRecordingAgents: myRangeElement with: myRangeElement sensorCrum with: agenda! {BooleanVar} testHChild: child {HistoryCrum} "Return true if child is a child. Used for debugging." ^(myRangeElement hCrum basicCast: Heaper star) == child! {void} triggerDetector: detect {FeFillRangeDetector} (myRangeElement isKindOf: BePlaceHolder) ifFalse: [detect rangeFilled: self asFeEdition]! {BooleanVar} updateBCrumTo: newBCrum {BertCrum} "My bertCrum must not be leafward of newBCrum. Thus it must be LE to newCrum. Otherwise correct it and recur." (super updateBCrumTo: newBCrum) ifTrue: [myRangeElement updateBCrumTo: newBCrum. ^true]. ^false! ! !RegionLoaf methodsFor: 'protected: delete'! {void} dismantle DiskManager consistent: 4 with: [(Heaper isConstructed: myRangeElement) ifTrue: [myRangeElement removeOParent: self]. super dismantle]! ! !RegionLoaf methodsFor: 'testing'! {UInt32} contentsHash ^super contentsHash bitXor: myRangeElement hashForEqual! ! !RegionLoaf methodsFor: 'smalltalk: passe'! {void} wait: sensor {XnSensor} self passe! ! !RegionLoaf methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myRangeElement _ receiver receiveHeaper. myLabel _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myRangeElement. xmtr sendHeaper: myLabel.! !OPart subclass: #OrglRoot instanceVariableNames: 'myHCrum {HBottomCrum}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Ents'! (OrglRoot getOrMakeCxxClassDescription) attributes: ((Set new) add: #SHEPHERD.PATRIARCH; add: #COPY; add: #DEFERRED; add: #DEFERRED.LOCKED; yourself)! !OrglRoot methodsFor: 'backfollow'! {XnRegion} attachTrailBlazer: blazer {TrailBlazer} self subclassResponsibility! {void} checkRecorders: finder {PropFinder} with: scrum {SensorCrum | NULL} "check any recorders that might be triggered by a change in the stamp" self subclassResponsibility! {void} checkTrailBlazer: blazer {TrailBlazer} self subclassResponsibility! {TrailBlazer | NULL} fetchTrailBlazer self subclassResponsibility! {AgendaItem} propChanger: change {PropChange} "NOTE: The AgendaItem returned is not yet scheduled. Doing so is up to my caller." ^myHCrum propChanger: change! {void} triggerDetector: detect {FeFillRangeDetector} "A Detector has been added to my parent. Walk down and trigger it on all non-partial stuff" self subclassResponsibility! {BooleanVar} updateBCrumTo: newBCrum {BertCrum} "Ensure the my bertCrum is not be leafward of newBCrum." (myHCrum propagateBCrum: newBCrum) ifTrue: [self diskUpdate. ^true]. ^false! ! !OrglRoot methodsFor: 'accessing'! {CoordinateSpace} coordinateSpace "the kind of domain elements allowed" self subclassResponsibility! {IntegerVar} count self subclassResponsibility! {XnRegion} domain self subclassResponsibility! {FeRangeElement | NULL} fetch: key {Position} with: edition {BeEdition} "get an individual element" self subclassResponsibility! {BeRangeElement} getBe: key {Position} "Get or Make the BeRangeElement at the location." self subclassResponsibility! {HistoryCrum} hCrum ^myHCrum! {TracePosition} hCut "This is primarily for the example routines." ^myHCrum hCut! {void} introduceEdition: edition {BeEdition} myHCrum introduceEdition: edition. self remember. self diskUpdate! {BooleanVar} isEmpty self subclassResponsibility! {XnRegion} keysLabelled: label {BeLabel} "Just search for now." self subclassResponsibility! {Mapping} mapSharedTo: trace {TracePosition} "return a mapping from my data to corresponding stuff in the given trace" self subclassResponsibility! {ID} ownerAt: key {Position} "Return the owner for the given position in the receiver." self subclassResponsibility! {XnRegion} rangeOwners: positions {XnRegion | NULL} self subclassResponsibility! {void} removeEdition: stamp {BeEdition} myHCrum removeEdition: stamp. myHCrum isEmpty ifTrue: ["Now we get into the risky part of deletion. Only Editions can keep OrglRoots around, so destroy the receiver." self destroy] ifFalse: [self diskUpdate]! {OrglRoot} setAllOwners: owner {ID} "Return the portiong whose owner couldn't be changed." self subclassResponsibility! {XnRegion} sharedRegion: trace {TracePosition} "Return a region for all the stuff in this orgl that can backfollow to trace." self subclassResponsibility! {XnRegion} simpleDomain "Return a simple region that encloses the domain of the receiver." self subclassResponsibility! {PrimSpec} specAt: key {Position} "Return the owner for the given position in the receiver." self subclassResponsibility! {XnRegion} usedDomain self subclassResponsibility! ! !OrglRoot methodsFor: 'operations'! {Stepper} bundleStepper: region {XnRegion} with: order {OrderSpec} "Return a stepper of bundles according to the order." self subclassResponsibility! {OrglRoot} combine: orgl {OrglRoot} self subclassResponsibility! {OrglRoot} copy: externalRegion {XnRegion} self subclassResponsibility! {void} delayedFindMatching: finder {PropFinder} with: fossil {RecorderFossil} with: recorder {ResultRecorder} "This does the 'now' part of setting up a recorder, once the 'later' part has been set up. It does a walk south on the O-tree, then walks back north on all the H-trees, filtered by the Bert canopy." self subclassResponsibility! {void} storeRecordingAgents: recorder {RecorderFossil} with: agenda {Agenda} "Go ahead and actually store the recorder in the sensor canopy. However, instead of propogating the props immediately, accumulate all those agenda items into the 'agenda' parameter. This is done instead of scheduling them directly because our client needs to schedule something else following all the prop propogation." self subclassResponsibility! {OrglRoot} transformedBy: externalDsp {Dsp} "Return a copy with externalDsp added to the receiver's dsp." self subclassResponsibility! {OrglRoot} unTransformedBy: externalDsp {Dsp} "Return a copy with externalDsp removed from the receiver's dsp." self subclassResponsibility! ! !OrglRoot methodsFor: 'protected:'! {void} dismantle DiskManager consistent: 3 with: [super dismantle. myHCrum _ NULL]! ! !OrglRoot methodsFor: 'create'! create: scrum {SensorCrum | NULL} super create: scrum. myHCrum _ HBottomCrum make.! ! !OrglRoot methodsFor: 'testing'! {UInt32} contentsHash ^super contentsHash bitXor: myHCrum hashForEqual! ! !OrglRoot methodsFor: 'smalltalk: passe'! {ScruTable} asDataTable self passe! {ScruTable} asTable self passe! {void} checkRecorders: edition {BeEdition} with: finder {PropFinder} with: scrum {SensorCrum | NULL} self passe "fewer args"! {void} delayedFindMatching: finder {PropFinder} with: recorder {RecorderFossil} self passe "extra argument"! {FeRangeElement | NULL} fetch: key {Position} self passe! {ScruTable of: ID and: BeEdition} findMatching: finder {PropFinder} self passe! {void} inform: key {Position} with: value {HRoot} self passe! {void} introduceStamp: stamp {BeEdition} self passe.! {void} propChanged: change {PropChange} self passe! {void} removeStamp: stamp {BeEdition} self passe.! {void} wait: sensor {XnSensor} self passe! ! !OrglRoot methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myHCrum _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myHCrum.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! OrglRoot class instanceVariableNames: ''! (OrglRoot getOrMakeCxxClassDescription) attributes: ((Set new) add: #SHEPHERD.PATRIARCH; add: #COPY; add: #DEFERRED; add: #DEFERRED.LOCKED; yourself)! !OrglRoot class methodsFor: 'creation'! make.CoordinateSpace: cs {CoordinateSpace} "create a new orgl root" "This should definitely be cached!! We make them all the time probably." self thingToDo. DiskManager consistent: 4 with: [^EmptyOrglRoot create: cs]! make.XnRegion: region {XnRegion} region isEmpty ifTrue: [^OrglRoot make: region coordinateSpace]. ^ActualOrglRoot make: (Loaf make.XnRegion: region) with: region! {OrglRoot} make: keys {XnRegion} with: ordering {OrderSpec} with: values {PtrArray of: FeRangeElement} | stepper {Stepper} result {OrglRoot} i {Int32} | result _ OrglRoot make.CoordinateSpace: ordering coordinateSpace. self hack. "This should make a balanced tree directly." i _ Int32Zero. stepper _ keys stepper: ordering. stepper forEach: [:key {Position} | | element {BeCarrier} region {XnRegion} | (values fetch: i) notNULL: [:fe {FeRangeElement} | element _ fe carrier] else: [Heaper BLAST: #MustNotHaveNullElements]. region _ key asRegion. result _ result combine: (ActualOrglRoot make: (Loaf make.Region: region with: element) with: region). i _ i + 1]. ^result! {OrglRoot} makeData: values {PrimDataArray} with: arrangement {Arrangement} "Make an Orgl from a bunch of Data. The data is guaranteed to be of a reasonable size." ^ActualOrglRoot make: (Loaf make: values with: arrangement) with: arrangement region! {OrglRoot} makeData: keys {XnRegion} with: ordering {OrderSpec} with: values {PrimDataArray} "Make an Orgl from a bunch of Data. The data is guaranteed to be of a reasonable size." ^ActualOrglRoot make: (Loaf make: values with: (ordering arrange: keys)) with: keys! ! !OrglRoot class methodsFor: 'smalltalk:'! {OrglRoot} make: it {Heaper} "create a new orgl root" (it isKindOf: CoordinateSpace) ifTrue: [^self make.CoordinateSpace: it]. (it isKindOf: XnRegion) ifTrue: [^self make.XnRegion: it]. ^self make.ScruTable: (it cast: ScruTable)! !OrglRoot subclass: #ActualOrglRoot instanceVariableNames: ' myO {Loaf} myRegion {XnRegion}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Ents'! (ActualOrglRoot getOrMakeCxxClassDescription) attributes: ((Set new) add: #SHEPHERD.PATRIARCH; add: #COPY; add: #LOCKED; add: #CONCRETE; yourself)! !ActualOrglRoot methodsFor: 'backfollow'! {XnRegion} attachTrailBlazer: blazer {TrailBlazer} ^myO attachTrailBlazer: blazer! {void} checkRecorders: finder {PropFinder} with: scrum {SensorCrum | NULL} myO checkRecorders: finder with: scrum! {void} checkTrailBlazer: blazer {TrailBlazer} myO checkTrailBlazer: blazer! {void} delayedFindMatching: finder {PropFinder} with: fossil {RecorderFossil} with: recorder {ResultRecorder} | hCrumCache {HashSetCache of: HistoryCrum} | "Cache for optimization: Frequently, in going northwards on the h-tree, one will encounter an h-crum already encountered during this very delayedFindMatching: operation. In this case, the cache helps us avoid *much* redundant work. We can get away with a bounded size cache because redundant work is still correct." hCrumCache _ HashSetCache make: 100. "Tell my O crum to do its flavor of the work. It will tell its children recursively." myO delayedStoreMatching: finder with: fossil with: recorder with: hCrumCache. hCrumCache destroy.! {TrailBlazer | NULL} fetchTrailBlazer ^myO fetchTrailBlazer! {void} storeRecordingAgents: recorder {RecorderFossil} with: agenda {Agenda} myO storeRecordingAgents: recorder with: agenda! {void} triggerDetector: detect {FeFillRangeDetector} myO triggerDetector: detect! {BooleanVar} updateBCrumTo: newBCrum {BertCrum} "My bertCrum must not be leafward of newBCrum. Thus it must be LE to newCrum. Otherwise correct it and recur." (super updateBCrumTo: newBCrum) ifTrue: [myO updateBCrumTo: newBCrum. ^true]. ^false! ! !ActualOrglRoot methodsFor: 'accessing'! {CoordinateSpace} coordinateSpace "the kind of domain elements allowed" ^myRegion coordinateSpace! {IntegerVar} count ^myO count! {XnRegion} domain ^myO domain! {FeRangeElement | NULL} fetch: key {Position} with: edition {BeEdition} "get an individual element" ^myO fetch: key with: edition with: key! {Loaf} fullcrum ^myO! {BeRangeElement} getBe: key {Position} "Get or Make the BeRangeElement at the location." "Separate the position from the rest of the oplane with copy. Then instantiate it." CurrentTrace fluidBind: self hCrum hCut during: [CurrentBertCrum fluidBind: self hCrum bertCrum during: [^((self copy: key asRegion) cast: ActualOrglRoot) fullcrum getBe: key]]! {BooleanVar} isEmpty "ActualOrglRoots believe they have stuff beneath them." ^false! {XnRegion} keysLabelled: label {BeLabel} "Just search for now." ^myO keysLabelled: label! {Mapping} mapSharedTo: trace {TracePosition} "return a mapping from my data to corresponding stuff in the given trace" ^myO compare: trace with: myRegion! {ID} ownerAt: key {Position} "Return the owner for the given position in the receiver." | loaf {OExpandingLoaf} | loaf _ myO fetchBottomAt: key. loaf == NULL ifTrue: [Heaper BLAST: #NotInTable]. ^loaf owner! {XnRegion} rangeOwners: positions {XnRegion | NULL} ^myO rangeOwners: positions! {OrglRoot} setAllOwners: owner {ID} "Recur assigning owners. Return the portion of the receiver that couldn't be assigned." ^myO setAllOwners: owner! {XnRegion} sharedRegion: trace {TracePosition} "Return a region for all the stuff in this orgl that can backfollow to trace." ^myO sharedRegion: trace with: myRegion! {XnRegion} simpleDomain ^myRegion! {PrimSpec} specAt: key {Position} "Return the owner for the given position in the receiver." | loaf {OExpandingLoaf} | loaf _ myO fetchBottomAt: key. loaf == NULL ifTrue: [Heaper BLAST: #NotInTable]. ^loaf spec! {Pair of: OrglRoot} tryAllBecome: other {OrglRoot} "Change the identities of the RangeElements of this Edition to those at the same key in the other Edition. The left piece of the result contains those object which are know to not be able to become, because of - lack of ownership authority - different contents - incompatible types - no corresponding new identity The right piece of the result is NULL if there is nothing more that might be done, or else the remainder of the receiver on which we might be able to proceed. This material might fail at a later time because of any of the reasons above; or it might succeed , even though it failed this time because of - synchronization problem - just didn't feel like it This is always required to make progress if it can, although it isn't required to make all the progress that it might. Returns right=NULL when it can't make further progress." Dean shouldImplement. ^NULL "fodder"! {XnRegion} usedDomain ^myO usedDomain! ! !ActualOrglRoot methodsFor: 'operations'! {Stepper} bundleStepper: region {XnRegion} with: order {OrderSpec} "Return a stepper of bundles according to the order." ^myO bundleStepper: region with: order with: region coordinateSpace identityDsp! {OrglRoot} combine: another {OrglRoot} | him {ActualOrglRoot} result {OrglRoot} | another isEmpty ifTrue: [^self]. him _ another cast: ActualOrglRoot. result _ self fetchEasyCombine: him. result ~~ NULL ifTrue: [^result]. result _ him fetchEasyCombine: self. result ~~ NULL ifTrue: [^result]. "both Ins are non-empty & both Outs are empty" ^myO combine: him with: myRegion with: self coordinateSpace identityDsp! {OrglRoot} copy: region {XnRegion} "Copy out each simple region and then combine them." region isSimple ifTrue: [^self copySimple: region] ifFalse: [| result {OrglRoot} | result _ OrglRoot make: self coordinateSpace. (region disjointSimpleRegions) forEach: [:simple {XnRegion} | result _ result combine: (self copySimple: simple)]. ^result]! {OrglRoot} copyDistinction: region {XnRegion} "region must be a valid thing to store as a split." | cnt {UInt8} | cnt _ self splay: region. Int0 == cnt ifTrue: [^OrglRoot make: self coordinateSpace] ifFalse: [2 == cnt ifTrue: [^self] ifFalse: [^ActualOrglRoot make: (myO cast: InnerLoaf) inPart with: (myRegion intersect: region)]]! {OrglRoot} copySimple: simpleRegion {XnRegion} "simpleRegion must be simple!! Copy out each distinction." | result {OrglRoot} | [ImmuSet] USES. result _ self. simpleRegion isSimple assert: 'This must be a simple region.'. simpleRegion distinctions stepper forEach: [:distinct {XnRegion} | result isEmpty ifTrue: [^result]. result _ (result cast: ActualOrglRoot) copyDistinction: distinct]. ^result! {void} fill: keys {XnRegion} with: toArrange {Arrangement} with: toArray {PrimDataArray} with: dsp {Dsp} with: edition {BeEdition} myO fill: keys with: toArrange with: toArray with: dsp with: edition! {ActualOrglRoot} makeNew: newSplit {XnRegion} with: newIn {ActualOrglRoot} with: newOut {ActualOrglRoot} ^ActualOrglRoot make: (InnerLoaf make: newSplit with: newIn fullcrum with: newOut fullcrum) with: (newIn simpleDomain simpleUnion: newOut simpleDomain)! {OrglRoot} transformedBy: externalDsp {Dsp} "Return a copy with externalDsp added to the receiver's dsp." externalDsp isIdentity ifTrue: [^self]. ^ActualOrglRoot make: (myO transformedBy: externalDsp) with: (externalDsp ofAll: myRegion)! {OrglRoot} unTransformedBy: externalDsp {Dsp} "Return a copy with externalDsp removed from the receiver's dsp." externalDsp isIdentity ifTrue: [^self]. ^ActualOrglRoot make: (myO unTransformedBy: externalDsp) with: (externalDsp inverseOfAll: myRegion)! ! !ActualOrglRoot methodsFor: 'create'! create: fullcrum {Loaf} with: region {XnRegion} super create: fullcrum sensorCrum. myO _ fullcrum. myRegion _ region. myO addOParent: self. self newShepherd! ! !ActualOrglRoot methodsFor: 'smalltalk:'! crums ^Array with: myO! displayString ^self getCategory name , (myO displayString)! inspect Sensor leftShiftDown ifTrue: [self basicInspect] ifFalse: [EntView openOn: (TreeBarnacle new buildOn: self gettingChildren: [:crum | crum crums] gettingImage: [:crum | DisplayText text: crum displayString asText textStyle: (TextStyle styleNamed: #small)] at: 0 @ 0 vertical: Sensor ctrlDown separation: 5 @ 10)]! inspectTraces Sensor leftShiftDown ifTrue: [self basicInspect] ifFalse: [EntView openOn: (TreeBarnacle new buildOn: myO gettingChildren: [:crum | crum crums] gettingImage: [:crum | DisplayText text: crum hCrum hCut displayString asText textStyle: (TextStyle styleNamed: #small)] at: 0 @ 0 vertical: true separation: 20 @ 20)]! {BooleanVar} testChild: child {SplayEntLoaf} "Return true if child is a child. Used for debugging." ^myO == child! {BooleanVar} testHChild: child {HistoryCrum} "Return true if child is a child. Used for debugging." ^ myO hCrum == child! ! !ActualOrglRoot methodsFor: 'printing'! {void} printOn: aStream {ostream reference} aStream << self getCategory name << '(' << myRegion << ', ' << myO << ')'! ! !ActualOrglRoot methodsFor: 'private:'! {ActualOrglRoot | NULL} fetchEasyCombine: another {ActualOrglRoot} another simpleDomain distinctions stepper forEach: [:bound {XnRegion} | | myIn {OrglRoot} myOut {OrglRoot} | myIn _ self copy: bound. myOut _ self copy: bound complement. myIn isEmpty ifTrue: [^self makeNew: bound with: another with: (myOut cast: ActualOrglRoot)]. myOut isEmpty not ifTrue: [^self makeNew: bound with: ((another combine: myIn) cast: ActualOrglRoot) with: (myOut cast: ActualOrglRoot)]]. ^NULL! {UInt8} splay: region {XnRegion} "Splay a region into its own subtree as close as possible to the root" ^myO splay: region with: myRegion! ! !ActualOrglRoot methodsFor: 'protected: delete'! {void} dismantle DiskManager consistent: 4 with: [(Heaper isConstructed: myO) ifTrue: [myO removeOParent: self]. super dismantle]! ! !ActualOrglRoot methodsFor: 'testing'! {UInt32} contentsHash ^(super contentsHash bitXor: myO hashForEqual) bitXor: myRegion hashForEqual! ! !ActualOrglRoot methodsFor: 'smalltalk: passe'! {void} inform: key {Position} with: value {HRoot} self passe! {void} wait: sensor {XnSensor} self passe! ! !ActualOrglRoot methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myO _ receiver receiveHeaper. myRegion _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myO. xmtr sendHeaper: myRegion.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ActualOrglRoot class instanceVariableNames: ''! (ActualOrglRoot getOrMakeCxxClassDescription) attributes: ((Set new) add: #SHEPHERD.PATRIARCH; add: #COPY; add: #LOCKED; add: #CONCRETE; yourself)! !ActualOrglRoot class methodsFor: 'creation'! make: loaf {Loaf} with: region {XnRegion} "create a new orgl root" region isEmpty not assert: 'Attempt to make an empty ActualOrglRoot'. DiskManager consistent: 13 with: [^ActualOrglRoot create: loaf with: region]! !OrglRoot subclass: #EmptyOrglRoot instanceVariableNames: 'myCS {CoordinateSpace}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Ents'! (EmptyOrglRoot getOrMakeCxxClassDescription) attributes: ((Set new) add: #SHEPHERD.PATRIARCH; add: #COPY; add: #LOCKED; add: #CONCRETE; yourself)! !EmptyOrglRoot methodsFor: 'backfollow'! {XnRegion} attachTrailBlazer: blazer {TrailBlazer} ^self domain! {void} checkRecorders: finder {PropFinder} with: scrum {SensorCrum | NULL}! {void} checkTrailBlazer: blazer {TrailBlazer unused} Heaper BLAST: #EmptyTrail! {void} delayedFindMatching: finder {PropFinder} with: fossil {RecorderFossil} with: recorder {ResultRecorder}! {TrailBlazer | NULL} fetchTrailBlazer ^NULL! {void} storeRecordingAgents: recorder {RecorderFossil} with: agenda {Agenda}! {void} triggerDetector: detect {FeFillRangeDetector}! ! !EmptyOrglRoot methodsFor: 'accessing'! {CoordinateSpace} coordinateSpace "the kind of domain elements allowed" ^myCS! {IntegerVar} count ^IntegerVar0! {XnRegion} domain ^myCS emptyRegion! {FeRangeElement | NULL} fetch: key {Position} with: edition {BeEdition} ^NULL! {BeRangeElement} getBe: key {Position} "Get or Make the BeRangeElement at the location." Heaper BLAST: #NotInTable. ^NULL! {BooleanVar} isEmpty ^true! {XnRegion} keysLabelled: label {BeLabel} "Just search for now." ^myCS emptyRegion! {Mapping} mapSharedTo: trace {TracePosition unused} "return a mapping from my data to corresponding stuff in the given trace" ^self coordinateSpace identityDsp! {ID} ownerAt: key {Position} "Return the owner for the given position in the receiver." Heaper BLAST: #NotInTable. ^NULL! {XnRegion} rangeOwners: positions {XnRegion | NULL} ^IDSpace global emptyRegion! {OrglRoot} setAllOwners: owner {ID} "There aren't any contents, so just return self." ^self! {XnRegion} sharedRegion: trace {TracePosition unused} "I have no contents, so I can't shared anything." ^ myCS emptyRegion! {XnRegion} simpleDomain "Return a simple region that encloses the domain of the receiver." ^ myCS emptyRegion! {PrimSpec} specAt: key {Position} "Return the owner for the given position in the receiver." Heaper BLAST: #NotInTable. ^NULL "fodder"! {XnRegion} usedDomain ^myCS emptyRegion! ! !EmptyOrglRoot methodsFor: 'operations'! {Stepper} bundleStepper: region {XnRegion} with: order {OrderSpec} "Return a stepper of bundles according to the order." ^Stepper emptyStepper! {OrglRoot} combine: orgl {OrglRoot} ^ orgl! {OrglRoot} copy: externalRegion {XnRegion unused} ^ self! {OrglRoot} transformedBy: externalDsp {Dsp unused} "Return a copy with externalDsp added to the receiver's dsp." ^ self! {OrglRoot} unTransformedBy: externalDsp {Dsp unused} "Return a copy with externalDsp removed from the receiver's dsp." ^ self! ! !EmptyOrglRoot methodsFor: 'create'! create: cs {CoordinateSpace} super create: (NULL basicCast: SensorCrum). myCS _ cs. self newShepherd! ! !EmptyOrglRoot methodsFor: 'smalltalk:'! crums ^#()! ! !EmptyOrglRoot methodsFor: 'testing'! {UInt32} contentsHash ^super contentsHash bitXor: myCS hashForEqual! ! !EmptyOrglRoot methodsFor: 'smalltalk: passe'! {void} inform: key {Position unused} with: value {HRoot unused} self passe! {void} propBy: anIObject {IObject unused} self passe! {void} unpropBy: anIObject {IObject unused} "Remove the endorsements for which aClubInfo is responsible. If there are no more references to this orgl, then it should be delete. This might also triggers sensors that wait for negative filters." self passe! {void} wait: sensor {XnSensor unused} self passe! ! !EmptyOrglRoot methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myCS _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myCS.! !Abraham subclass: #PairFlock instanceVariableNames: ' myLeft {Abraham} myRight {Abraham}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Snarf'! (PairFlock getOrMakeCxxClassDescription) attributes: ((Set new) add: #SHEPHERD.PATRIARCH; add: #COPY; add: #EQ; add: #LOCKED; add: #CONCRETE; yourself)! !PairFlock methodsFor: 'accessing'! {Abraham} left ^myLeft! {Abraham} right ^myRight! ! !PairFlock methodsFor: 'creation'! create: left {Abraham} with: right {Abraham} super create. myLeft _ left. myRight _ right. self newShepherd! ! !PairFlock methodsFor: 'testing'! {UInt32} contentsHash ^(super contentsHash bitXor: myLeft hashForEqual) bitXor: myRight hashForEqual! ! !PairFlock methodsFor: 'generated:'! actualHashForEqual ^self asOop! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myLeft _ receiver receiveHeaper. myRight _ receiver receiveHeaper.! isEqual: other ^self == other! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myLeft. xmtr sendHeaper: myRight.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PairFlock class instanceVariableNames: ''! (PairFlock getOrMakeCxxClassDescription) attributes: ((Set new) add: #SHEPHERD.PATRIARCH; add: #COPY; add: #EQ; add: #LOCKED; add: #CONCRETE; yourself)! !PairFlock class methodsFor: 'creation'! make: left {Abraham} with: right {Abraham} ^self create: left with: right! !Abraham subclass: #Pumpkin instanceVariableNames: '' classVariableNames: 'TheGreatPumpkin {Abraham} ' poolDictionaries: '' category: 'Xanadu-Snarf'! (Pumpkin getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #EQ; add: #CONCRETE; yourself)! !Pumpkin methodsFor: 'protected: protected'! {void} becomeStub "This can only be implemented by classes which are shepherds." "Each subclass will have expressions of the form: 'new (this) MyStubClass()'" self shouldNotImplement! ! !Pumpkin methodsFor: 'creation'! create: hash {UInt32} super create: hash! ! !Pumpkin methodsFor: 'generated:'! actualHashForEqual ^self asOop! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! isEqual: other ^self == other! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Pumpkin class instanceVariableNames: ''! (Pumpkin getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #EQ; add: #CONCRETE; yourself)! !Pumpkin class methodsFor: 'smalltalk: initialization'! linkTimeNonInherited TheGreatPumpkin _ NULL! ! !Pumpkin class methodsFor: 'pcreate'! {Abraham wimpy} make "Just return the soleInstance." TheGreatPumpkin == NULL ifTrue: [TheGreatPumpkin _ self create: 1. TheGreatPumpkin flockInfo: (FlockInfo remembered: TheGreatPumpkin with: Int32Zero with: Int32Zero)]. ^TheGreatPumpkin! !Abraham subclass: #RecorderFossil instanceVariableNames: ' myLoginAuthority {IDRegion} myTrailBlazer {TrailBlazer | NULL} myRecorder {ResultRecorder NOCOPY | NULL} myRecorderCount {IntegerVar NOCOPY} myAgendaCount {IntegerVar}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-fossil'! RecorderFossil comment: 'A Fossil for a ResultRecorder, which also stores its permissions, filters, and a cache of the results which have already been recorded.'! (RecorderFossil getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #DEFERRED.LOCKED; yourself)! !RecorderFossil methodsFor: 'accessing'! {void} addItem: item {AgendaItem unused} DiskManager insistent: 1 with: [myAgendaCount _ myAgendaCount + 1. self diskUpdate. self memoryCheck]! {void} extinguish: trailBlazer {TrailBlazer} "Should only be called from BeEdition::fossilRelease(). Results in my becoming extinct." myTrailBlazer == NULL ifTrue: [Heaper BLAST: #AlreadyExtinct]. (myTrailBlazer isEqual: trailBlazer) not ifTrue: [Heaper BLAST: #WhoSays]. myRecorderCount ~= Int32Zero ifTrue: [Heaper BLAST: #RecordersStillOutstanding]. myRecorder ~~ NULL ifTrue: [myRecorder destroy. myRecorder _ NULL]. DiskManager insistent: 1 with: [myTrailBlazer _ NULL. self diskUpdate. self memoryCheck]! {void} releaseRecorder "As a premature optimization, we don't destroy the waldo when the count goes to zero, but rather when we consider purging while the count is zero." (myRecorderCount >= 1) assert. myRecorderCount _ myRecorderCount - 1! {void} removeItem: item {AgendaItem unused} (myAgendaCount >= 1) assert. DiskManager insistent: 1 with: [myAgendaCount _ myAgendaCount - 1. self diskUpdate. self memoryCheck]! {ResultRecorder} secretRecorder "The Recorder of which this Fossil is the imprint. If necessary, reconstruct it using the information stored in the imprint. Should only be called if I am not extinct Should only be called from the reanimate macro." | | "If I'm extinct, somebody goofed. Blow 'em up. If we haven't already reanimated a recorder (because this is the outermost reanimate for this fossil) bind a new current KeyMaster (recovering the fossilized permissions) make a recorder implicitly using the fossilized permissions and explicitly using the fossilized endorsements and trail. bump the refcount on myRecorder return myRecorder" self isExtinct ifTrue: [Heaper BLAST: #FossilExtinct]. myRecorder == NULL ifTrue: [CurrentKeyMaster fluidBind: (FeKeyMaster makeAll: myLoginAuthority) during: [myRecorder := self actualRecorder]]. myRecorderCount := myRecorderCount + 1. ^myRecorder! ! !RecorderFossil methodsFor: 'smalltalk: reanimation'! {void} reanimate: aBlock {BlockClosure of: RecorderFossil} "Should only be called if I am not extinct. f reanimate: [:w {RecorderFossil} | ...] should translate to BEGIN_REANIMATE(f,RecorderFossil,w) { ... } END_REANIMATE;" [aBlock value: self secretRecorder] valueNowOrOnUnwindDo: (RecorderFossil bomb.ReleaseRecorder: self)! ! !RecorderFossil methodsFor: 'testing'! {BooleanVar} isExtinct "A Fossil (unlike a Grabber or an Orgl) does not prevent the grabbed IObject from being dismantled. Instead, if the IObject does get dismantled, then the Fossil is considered extinct. A waldo may not be gotten from an extinct fossil (if the species is really extinct, then it cannot be revived from its remaining fossils)." ^myTrailBlazer == NULL! {BooleanVar} isPurgeable "I can`t go to disk while someone has my WaldoSocket and might be doing something with the Waldo in it." (super isPurgeable and: [myRecorderCount == Int32Zero]) ifTrue: [myRecorder ~~ NULL ifTrue: [myRecorder destroy. myRecorder _ NULL]. ^true] ifFalse: [^false]! ! !RecorderFossil methodsFor: 'hooks:'! {void RECEIVE.HOOK} restartRecorderFossil: rcvr {Rcvr unused default: NULL} myRecorder _ NULL. myRecorderCount _ Int32Zero! ! !RecorderFossil methodsFor: 'protected: destruction'! {void} dismantle (myRecorderCount = Int32Zero) assert. "(myAgendaCount = Int32Zero) assert." myRecorder ~~ NULL ifTrue: [myRecorder destroy. myRecorder _ NULL]. DiskManager consistent: 2 with: [(Heaper isConstructed: myTrailBlazer) ifTrue: [myTrailBlazer removeReference: self]. myTrailBlazer := NULL. super dismantle]! ! !RecorderFossil methodsFor: 'protected: accessing'! {ResultRecorder} actualRecorder "Make the right kind of Recorder for this fossil" self subclassResponsibility! {void} memoryCheck (myTrailBlazer == NULL "and: [myAgendaCount = Int32Zero]") ifTrue: [self forget] ifFalse: [self remember]! {TrailBlazer} trailBlazer myTrailBlazer == NULL ifTrue: [Heaper BLAST: #FatalError]. "should have already been checked" ^myTrailBlazer! ! !RecorderFossil methodsFor: 'create'! create: loginAuthority {IDRegion} with: trailBlazer {TrailBlazer} super create. myLoginAuthority := loginAuthority. myTrailBlazer := trailBlazer. myTrailBlazer addReference: self. myAgendaCount _ Int32Zero. self restartRecorderFossil: NULL.! ! !RecorderFossil methodsFor: 'backfollow'! {void} storeDataRecordingAgents: sensorCrum {SensorCrum} with: agenda {Agenda} "Store recording agents into a SensorCrum on data in the original Edition that was a source of the query" agenda registerItem: (sensorCrum recordingAgent: self) "default behaviour"! {void} storePartialityRecordingAgents: sensorCrum {SensorCrum} with: agenda {Agenda} "Store recording agents into a SensorCrum on partiality in the original Edition that was a source of the query" agenda registerItem: (sensorCrum recordingAgent: self) "default behaviour"! {void} storeRangeElementRecordingAgents: rangeElement {BeRangeElement unused} with: sensorCrum {SensorCrum} with: agenda {Agenda} "Store recording agents into a SensorCrum on a RangeElement in the original Edition that was a source of the query" agenda registerItem: (sensorCrum recordingAgent: self) "default behaviour"! ! !RecorderFossil methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myLoginAuthority _ receiver receiveHeaper. myTrailBlazer _ receiver receiveHeaper. myAgendaCount _ receiver receiveIntegerVar. self restartRecorderFossil: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myLoginAuthority. xmtr sendHeaper: myTrailBlazer. xmtr sendIntegerVar: myAgendaCount.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RecorderFossil class instanceVariableNames: ''! (RecorderFossil getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #DEFERRED.LOCKED; yourself)! !RecorderFossil class methodsFor: 'create'! {RecorderFossil} transcluders: isDirectOnly {BooleanVar} with: loginAuthority {IDRegion} with: directFilter {Filter of: (Tuple of: ID with: ID)} with: indirectFilter {Filter of: (Tuple of: ID with: ID)} with: trailBlazer {TrailBlazer} DiskManager consistent: 2 with: [isDirectOnly ifTrue: [^DirectEditionRecorderFossil create: loginAuthority with: directFilter with: indirectFilter with: trailBlazer] ifFalse: [^IndirectEditionRecorderFossil create: loginAuthority with: directFilter with: indirectFilter with: trailBlazer]]! {RecorderFossil} works: isDirectOnly {BooleanVar} with: loginAuthority {IDRegion} with: endorsementsFilter {Filter of: (Tuple of: ID with: ID)} with: trailBlazer {TrailBlazer} DiskManager consistent: 2 with: [isDirectOnly ifTrue: [^DirectWorkRecorderFossil create: loginAuthority with: endorsementsFilter with: trailBlazer] ifFalse: [^IndirectWorkRecorderFossil create: loginAuthority with: endorsementsFilter with: trailBlazer]]! ! !RecorderFossil class methodsFor: 'exceptions: exceptions'! bomb.ReleaseRecorder: CHARGE {RecorderFossil} ^[CHARGE releaseRecorder]! ! !RecorderFossil class methodsFor: 'smalltalk: passe'! make: loginAuthority {IDRegion} with: eFilter {Filter of: (Tuple of: ID with: ID)} with: trail {BeEdition} self passe! !RecorderFossil subclass: #EditionRecorderFossil instanceVariableNames: ' myDirectFilter {Filter} myIndirectFilter {Filter}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-fossil'! EditionRecorderFossil comment: 'A Fossil for an EditionRecorder.'! (EditionRecorderFossil getOrMakeCxxClassDescription) attributes: ((Set new) add: #SHEPHERD.PATRIARCH; add: #COPY; add: #DEFERRED; add: #DEFERRED.LOCKED; add: #NOT.A.TYPE; yourself)! !EditionRecorderFossil methodsFor: 'protected: accessing'! {ResultRecorder} actualRecorder self subclassResponsibility! {Filter} directFilter ^myDirectFilter! {Filter} indirectFilter ^myIndirectFilter! ! !EditionRecorderFossil methodsFor: 'create'! create: loginAuthority {IDRegion} with: directFilter {Filter} with: indirectFilter {Filter} with: trailBlazer {TrailBlazer} super create: loginAuthority with: trailBlazer. myDirectFilter := directFilter. myIndirectFilter := indirectFilter.! ! !EditionRecorderFossil methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myDirectFilter _ receiver receiveHeaper. myIndirectFilter _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myDirectFilter. xmtr sendHeaper: myIndirectFilter.! !EditionRecorderFossil subclass: #DirectEditionRecorderFossil instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-fossil'! DirectEditionRecorderFossil comment: 'A Fossil for an EditionRecorder with the directOnly flag set.'! (DirectEditionRecorderFossil getOrMakeCxxClassDescription) attributes: ((Set new) add: #SHEPHERD.PATRIARCH; add: #COPY; add: #LOCKED; add: #NOT.A.TYPE; add: #CONCRETE; yourself)! !DirectEditionRecorderFossil methodsFor: 'protected: accessing'! {ResultRecorder} actualRecorder ^DirectEditionRecorder create: self directFilter with: self indirectFilter with: self trailBlazer! ! !DirectEditionRecorderFossil methodsFor: 'create'! create: loginAuthority {IDRegion} with: directFilter {Filter} with: indirectFilter {Filter} with: trailBlazer {TrailBlazer} super create: loginAuthority with: directFilter with: indirectFilter with: trailBlazer. self newShepherd. self remember.! ! !DirectEditionRecorderFossil methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !EditionRecorderFossil subclass: #IndirectEditionRecorderFossil instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-fossil'! IndirectEditionRecorderFossil comment: 'A Fossil for an EditionRecorder with the directOnly flag off.'! (IndirectEditionRecorderFossil getOrMakeCxxClassDescription) attributes: ((Set new) add: #SHEPHERD.PATRIARCH; add: #COPY; add: #LOCKED; add: #NOT.A.TYPE; add: #CONCRETE; yourself)! !IndirectEditionRecorderFossil methodsFor: 'protected: accessing'! {ResultRecorder} actualRecorder ^IndirectEditionRecorder create: self directFilter with: self indirectFilter with: self trailBlazer! ! !IndirectEditionRecorderFossil methodsFor: 'create'! create: loginAuthority {IDRegion} with: directFilter {Filter} with: indirectFilter {Filter} with: trailBlazer {TrailBlazer} super create: loginAuthority with: directFilter with: indirectFilter with: trailBlazer. self newShepherd. self remember.! ! !IndirectEditionRecorderFossil methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !RecorderFossil subclass: #WorkRecorderFossil instanceVariableNames: 'myEndorsementsFilter {Filter}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-fossil'! WorkRecorderFossil comment: 'A Fossil for a WorkRecorder.'! (WorkRecorderFossil getOrMakeCxxClassDescription) attributes: ((Set new) add: #SHEPHERD.PATRIARCH; add: #COPY; add: #DEFERRED; add: #DEFERRED.LOCKED; add: #NOT.A.TYPE; yourself)! !WorkRecorderFossil methodsFor: 'protected: accessing'! {ResultRecorder} actualRecorder self subclassResponsibility! {Filter} endorsementsFilter ^myEndorsementsFilter! ! !WorkRecorderFossil methodsFor: 'create'! create: loginAuthority {IDRegion} with: endorsementsFilter {Filter} with: trailBlazer {TrailBlazer} super create: loginAuthority with: trailBlazer. myEndorsementsFilter := endorsementsFilter.! ! !WorkRecorderFossil methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myEndorsementsFilter _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myEndorsementsFilter.! !WorkRecorderFossil subclass: #DirectWorkRecorderFossil instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-fossil'! DirectWorkRecorderFossil comment: 'A Fossil for a DirectWorkRecorder.'! (DirectWorkRecorderFossil getOrMakeCxxClassDescription) attributes: ((Set new) add: #SHEPHERD.PATRIARCH; add: #COPY; add: #LOCKED; add: #NOT.A.TYPE; add: #CONCRETE; yourself)! !DirectWorkRecorderFossil methodsFor: 'protected: accessing'! {ResultRecorder} actualRecorder ^DirectWorkRecorder create: self endorsementsFilter with: self trailBlazer! ! !DirectWorkRecorderFossil methodsFor: 'create'! create: loginAuthority {IDRegion} with: endorsementsFilter {Filter} with: trailBlazer {TrailBlazer} super create: loginAuthority with: endorsementsFilter with: trailBlazer. self newShepherd. self remember.! ! !DirectWorkRecorderFossil methodsFor: 'backfollow'! {void} storeDataRecordingAgents: sensorCrum {SensorCrum} with: agenda {Agenda} "do nothing"! {void} storeRangeElementRecordingAgents: rangeElement {BeRangeElement} with: sensorCrum {SensorCrum} with: agenda {Agenda} ((rangeElement isKindOf: BeEdition) or: [rangeElement isKindOf: BePlaceHolder]) ifTrue: [super storeRangeElementRecordingAgents: rangeElement with: sensorCrum with: agenda]! ! !DirectWorkRecorderFossil methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !WorkRecorderFossil subclass: #IndirectWorkRecorderFossil instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-fossil'! IndirectWorkRecorderFossil comment: 'A Fossil for a IndirectWorkRecorder.'! (IndirectWorkRecorderFossil getOrMakeCxxClassDescription) attributes: ((Set new) add: #SHEPHERD.PATRIARCH; add: #COPY; add: #LOCKED; add: #NOT.A.TYPE; add: #CONCRETE; yourself)! !IndirectWorkRecorderFossil methodsFor: 'protected: accessing'! {ResultRecorder} actualRecorder ^IndirectWorkRecorder create: self endorsementsFilter with: self trailBlazer! ! !IndirectWorkRecorderFossil methodsFor: 'create'! create: loginAuthority {IDRegion} with: endorsementsFilter {Filter} with: trailBlazer {TrailBlazer} super create: loginAuthority with: endorsementsFilter with: trailBlazer. self newShepherd. self remember.! ! !IndirectWorkRecorderFossil methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !Abraham subclass: #SharedData instanceVariableNames: ' myArrangement {Arrangement} myData {PrimArray}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Ents'! (SharedData getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !SharedData methodsFor: 'accessing'! {UInt32} contentsHash ^super contentsHash bitXor: myData contentsHash! {Heaper | NULL} fetch: key {Position} ^myData fetchValue: (myArrangement indexOf: key) DOTasLong! {void} fill: keys {XnRegion} with: toArrange {Arrangement} with: toArray {PrimArray} with: dsp {Dsp} "Transfer my data into the toArray mapping through my arrangement and his arrangement." keys isEmpty ifFalse: [toArrange copyElements: toArray with: dsp with: myData with: myArrangement with: (dsp inverseOfAll: keys)]! {PrimSpec} spec "Return the primSpec for my data." ^myData spec! ! !SharedData methodsFor: 'creation'! create: data {PrimDataArray} with: arrange {Arrangement} super create. myData _ data. myArrangement _ arrange. myData count = myArrangement region count DOTasLong assert: 'Invalid arrangement'. self newShepherd. self remember! ! !SharedData methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myArrangement _ receiver receiveHeaper. myData _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myArrangement. xmtr sendHeaper: myData.! !Abraham subclass: #ShepherdLocked instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-sheph'! (ShepherdLocked getOrMakeCxxClassDescription) friends: '/* friends for class ShepherdLocked */'; attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !ShepherdLocked methodsFor: 'instance creation'! create super create! ! !ShepherdLocked methodsFor: 'accessing'! {BooleanVar} isReallyUnlocked [^ (StackExaminer pointersOnStack fetch: self asOop) == NULL] smalltalkOnly. 'return StackExaminer::pointersOnStack()->fetch((Int32)(void*)this) == NULL;' translateOnly.! ! !ShepherdLocked methodsFor: 'testing locks'! {void} publicUnlock "self unlock"! ! !ShepherdLocked methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ShepherdLocked class instanceVariableNames: ''! (ShepherdLocked getOrMakeCxxClassDescription) friends: '/* friends for class ShepherdLocked */'; attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !ShepherdLocked class methodsFor: 'instance creation'! {ShepherdLocked} makeLocked ^ShepherdLocked create! {ShepherdLocked} makeUnlocked | aLockedShepherd {ShepherdLocked} | aLockedShepherd _ ShepherdLocked create. aLockedShepherd publicUnlock. ^aLockedShepherd! !Abraham subclass: #TrailBlazer instanceVariableNames: ' myTrail {BeEdition} myRecorded {HashSetCache of: BeRangeElement} myRefCount {IntegerVar}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-tclude'! TrailBlazer comment: 'The object responsible for recording results into a trail. '! (TrailBlazer getOrMakeCxxClassDescription) attributes: ((Set new) add: #SHEPHERD.PATRIARCH; add: #COPY; add: #EQ; add: #LOCKED; add: #CONCRETE; yourself)! !TrailBlazer methodsFor: 'create'! create super create. myTrail := NULL. myRecorded := HashSetCache make. myRefCount := IntegerVarZero. self newShepherd.! ! !TrailBlazer methodsFor: 'private:'! {void} setEdition: trail {BeEdition} myTrail := trail. self diskUpdate.! ! !TrailBlazer methodsFor: 'accessing'! {BooleanVar} isAlive "Whether this TrailBlazer was in fact successfully attached" ^myTrail ~~ NULL! {void} record: answer {BeRangeElement} "record the answer into my Edition, and keep only the partial part. Should usually suppress redundant records of the same object. (These are typically generated by a race between the now and future parts of a backfollow, which are guaranteed to err by overlapping rather than gapping. They may also be generated by a crash/reboot during AgendaItem processing.)" (myRecorded hasMember: answer) ifFalse: [ | iD {ID} newTrail {BeEdition} | iD := (myTrail coordinateSpace cast: IDSpace) newID. TrailBlazer problems.RecordFailure handle: [ :ex | ^VOID] do: [(myTrail get: iD) makeIdentical: (answer makeFe: NULL)]. myRecorded store: answer. Ravi thingToDo. "This should not be an edit operation (?)" newTrail := myTrail without: iD. Ravi thingToDo. "decrease refcount on old trail, increase on new one" DiskManager consistent: 1 with: [myTrail := newTrail. self diskUpdate]]! ! !TrailBlazer methodsFor: 'storage'! {void} addReference: object {Abraham unused} "Increment the reference count" DiskManager consistent: 1 with: [myRefCount := myRefCount + 1. myRefCount = 1 ifTrue: [self remember]. self diskUpdate]! {void} removeReference: object {Abraham unused} "Decrement the reference count" DiskManager consistent: 1 with: [myRefCount := myRefCount - 1. myRefCount = IntegerVarZero ifTrue: [self forget]. self diskUpdate]! ! !TrailBlazer methodsFor: 'generated:'! actualHashForEqual ^self asOop! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myTrail _ receiver receiveHeaper. myRecorded _ receiver receiveHeaper. myRefCount _ receiver receiveIntegerVar.! isEqual: other ^self == other! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myTrail. xmtr sendHeaper: myRecorded. xmtr sendIntegerVar: myRefCount.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TrailBlazer class instanceVariableNames: ''! (TrailBlazer getOrMakeCxxClassDescription) attributes: ((Set new) add: #SHEPHERD.PATRIARCH; add: #COPY; add: #EQ; add: #LOCKED; add: #CONCRETE; yourself)! !TrailBlazer class methodsFor: 'create'! make: trail {BeEdition} "should only be called from Edition::getOrMakeTrailBlazer" | result {TrailBlazer} partial {XnRegion} sub {BeEdition} | DiskManager consistent: 1 with: [result := self create]. partial := trail attachTrailBlazer: result. sub := trail copy: partial. DiskManager consistent: 1 with: [result setEdition: sub]. "this makes the blazer be alive, once attached" ^result! ! !TrailBlazer class methodsFor: 'exceptions:'! problems.RecordFailure ^Heaper signals: #(MustBeOwner CantMakeIdentical NotInTable)! !Abraham subclass: #Turtle instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Snarf'! (Turtle getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #DEFERRED.LOCKED; yourself)! !Turtle methodsFor: 'accessing'! {Category} bootCategory self subclassResponsibility! {Heaper} bootHeaper self subclassResponsibility! {Cookbook} cookbook self subclassResponsibility! {Counter} counter self subclassResponsibility! {Agenda | NULL} fetchAgenda "Under all normal conditions, a Turtle has an Agenda. However, during the construction of a Turtle, there may arise situations when a piece of code is invoked which normally asks the Turtle for its agenda before the Turtle is mature enough to have one." self subclassResponsibility! {Agenda} getAgenda "See Turtle::fetchAgenda()" | result {Agenda | NULL} | result _ self fetchAgenda. result == NULL ifTrue: [Heaper BLAST: #TurtleNotMature]. ^result! {XcvrMaker} protocol self subclassResponsibility! {void} saveBootHeaper: boot {Heaper} self subclassResponsibility! {void} setProtocol: xcvrMaker {XcvrMaker} with: book {Cookbook} self subclassResponsibility! ! !Turtle methodsFor: 'protected: creation'! create super create! create: hash {UInt32} super create: hash! ! !Turtle methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Turtle class instanceVariableNames: ''! (Turtle getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #DEFERRED.LOCKED; yourself)! !Turtle class methodsFor: 'pseudo-constructors'! make: cookbook {Cookbook} with: bootCategory {Category} with: maker {XcvrMaker} ^SimpleTurtle make: cookbook with: bootCategory with: maker! !Turtle subclass: #MockTurtle instanceVariableNames: ' myAgenda {Agenda | NULL} myBootCategory {Category}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Snarf'! MockTurtle comment: 'The MockTurtle is used with the FakePacker. All it provides is an Agenda'! (MockTurtle getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #LOCKED; add: #COPY; yourself)! !MockTurtle methodsFor: 'accessing'! {Category} bootCategory ^ myBootCategory! {Heaper} bootHeaper self unimplemented. ^NULL "fodder"! {Cookbook} cookbook self willNotImplement. ^ NULL! {Counter} counter self willNotImplement. ^NULL "fodder"! {Agenda | NULL} fetchAgenda ^myAgenda! {XcvrMaker} protocol self willNotImplement. ^ NULL! {void} saveBootHeaper: boot {Heaper} "Right" self willNotImplement.! {void} setProtocol: xcvrMaker {XcvrMaker} with: book {Cookbook} "Right" self willNotImplement.! ! !MockTurtle methodsFor: 'protected: creation'! create: bootCategory {Category} super create. (CurrentPacker fluidGet cast: FakePacker) storeTurtle: self. myAgenda _ NULL. myBootCategory _ bootCategory. myAgenda _ Agenda make.! ! !MockTurtle methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myAgenda _ receiver receiveHeaper. myBootCategory _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myAgenda. xmtr sendHeaper: myBootCategory.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MockTurtle class instanceVariableNames: ''! (MockTurtle getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #LOCKED; add: #COPY; yourself)! !MockTurtle class methodsFor: 'pseudo-constructor'! {Turtle} make: category {Category} ^ self create: category! !Turtle subclass: #SimpleTurtle instanceVariableNames: ' myCounter {Counter} myBootHeaper {Heaper} myProtocol {XcvrMaker NOCOPY} myCookbook {Cookbook NOCOPY} myBootCategory {Category} myAgenda {Agenda | NULL}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Snarf'! (SimpleTurtle getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #LOCKED; add: #COPY; yourself)! !SimpleTurtle methodsFor: 'accessing'! {Category} bootCategory ^myBootCategory! {Heaper} bootHeaper ^myBootHeaper! {Cookbook} cookbook ^myCookbook! {Counter} counter ^myCounter! {Agenda | NULL} fetchAgenda ^myAgenda! {XcvrMaker} protocol ^myProtocol! {void} saveBootHeaper: boot {Heaper} myBootHeaper == NULL ifFalse: [Turtle BLAST: #DontChangeTurtlesBootHeaper] ifTrue: [DiskManager consistent: 1 with: [myBootHeaper _ boot. self diskUpdate]]! {void} setProtocol: xcvrMaker {XcvrMaker} with: book {Cookbook} myProtocol _ xcvrMaker. myCookbook _ book.! ! !SimpleTurtle methodsFor: 'testing'! {UInt32} contentsHash ^((super contentsHash bitXor: myCounter hashForEqual) bitXor: myBootHeaper hashForEqual) bitXor: myProtocol hashForEqual! ! !SimpleTurtle methodsFor: 'hooks:'! {void RECEIVE.HOOK} restartSimpleTurtle: rcvr {Rcvr unused default: NULL} myProtocol _ XcvrMaker make. "The bogus protocol" myCookbook _ Cookbook make "with the empty cookbook"! ! !SimpleTurtle methodsFor: 'protected: creation'! create: cookbook {Cookbook} with: bootCategory {Category} with: maker {XcvrMaker} | packer {DiskManager} | super create: 1. packer _ CurrentPacker fluidGet cast: DiskManager. DiskManager consistent: 1 with: [myCounter _ NULL. myBootHeaper _ NULL. myProtocol _ maker. myCookbook _ cookbook. myBootCategory _ bootCategory. myAgenda _ NULL. packer storeInitialFlock: self with: myProtocol with: cookbook]. DiskManager consistent: 3 with: [self thingToDo. "tune the number 5000" myCounter _ Counter fakeCounter: 3 with: 5000 with: 2. packer setHashCounter: myCounter. self remember. myCounter newShepherd. myCounter remember. myAgenda _ Agenda make. myAgenda rememberYourself]! ! !SimpleTurtle methodsFor: 'smalltalk: passe'! {void} newCounter: counter {Counter} self passe! ! !SimpleTurtle methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myCounter _ receiver receiveHeaper. myBootHeaper _ receiver receiveHeaper. myBootCategory _ receiver receiveHeaper. myAgenda _ receiver receiveHeaper. self restartSimpleTurtle: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myCounter. xmtr sendHeaper: myBootHeaper. xmtr sendHeaper: myBootCategory. xmtr sendHeaper: myAgenda.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! SimpleTurtle class instanceVariableNames: ''! (SimpleTurtle getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #LOCKED; add: #COPY; yourself)! !SimpleTurtle class methodsFor: 'pseudo-constructors'! make: cookbook {Cookbook} with: bootCategory {Category} with: maker {XcvrMaker} ^SimpleTurtle create: cookbook with: bootCategory with: maker! !Heaper subclass: #Accumulator instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Steppers'! Accumulator comment: 'An Accumulator is a thing which collects a sequence of objects one at a time for some purpose. Typically, this purpose is to construct a new object out of all the collected objects. When used in this way, one can think of the Accumulator as being sort of like a pseudo-constructor which is spread out in time, and whose arguments are identified by the sequence they occur in. Accumulators are typically used in loops. A (future) example of an Accumulator which is not like "a pseudo-constructor spread out in time" is a communications stream between two threads (or even coroutines) managed by an Accumulator / Stepper pair. The producer process produces by putting objects into his Accumulator, and the consuming process consumes by pulling values out of his Stepper. If you want to stretch the analogy, I suppose you can see the Accumulator of the pair as a pseudo-constructor which constructs the Stepper, but *overlapped* in time. It is normally considered bad style for two methods/functions to be pointing at the same Acumulator. As long as Accumulators are used locally and without aliasing (i.e., as if they were pass-by-value Vars), these implementationally side-effecty objects can be understood applicatively. If a copy of an Accumulator can be passed instead of a pointer to the same one, this is to be prefered. This same comment applies even more so for Steppers. Example: To build a set consisting of some transform of the elements of an existing set (what Smalltalk would naturally do with "collect:"), a natural form for the loop would be: SPTR(Accumulator) acc = setAccumulator(); FOR_EACH(Heaper,each,oldSet->stepper(), { acc->step (transform (each)); }); return CAST(ImmuSet,acc->value()); See class Stepper for documentation of FOR_EACH.'! (Accumulator getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #EQ; yourself)! !Accumulator methodsFor: 'deferred operations'! {void} step: someObj {Heaper} "Accumulate a new object into the Accumulator" self subclassResponsibility! {Heaper} value "Return the object that results from accumulating all those objects" self subclassResponsibility! ! !Accumulator methodsFor: 'deferred creation'! {Accumulator} copy "Return a new Accumulator just like the current one, except that from now on they accumulate separately" self subclassResponsibility! ! !Accumulator methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Accumulator class instanceVariableNames: ''! (Accumulator getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #EQ; yourself)! !Accumulator class methodsFor: 'creation'! {Accumulator INLINE} ptrArray "An accumulator that returns a PtrArray of the object put into it, in sequence" ^PtrArrayAccumulator create! !Accumulator subclass: #BoxAccumulator instanceVariableNames: ' mySpace {CrossSpace} myRegions {PtrArray of: XnRegion} myIndex {Int32}' classVariableNames: 'SomeAccumulators {InstanceCache} ' poolDictionaries: '' category: 'Xanadu-cross'! BoxAccumulator comment: 'was NOT.A.TYPE but this prevented compilation '! (BoxAccumulator getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !BoxAccumulator methodsFor: 'creation'! {Accumulator} copy | result {Heaper} | result := SomeAccumulators fetch. result == NULL ifTrue: [^BoxAccumulator create: mySpace with: (myRegions copy cast: PtrArray) with: myIndex] ifFalse: [^(BoxAccumulator new.Become: result) create: mySpace with: (myRegions copy cast: PtrArray) with: myIndex]! ! !BoxAccumulator methodsFor: 'protected: creation'! create: region {GenericCrossRegion} super create. mySpace := region crossSpace. myRegions := region secretRegions copy cast: PtrArray. myIndex := region boxCount.! create: space {CrossSpace} with: expectedBoxCount {Int32} super create. mySpace := space. myRegions := PtrArray nulls: space axisCount * expectedBoxCount. myIndex := Int32Zero.! create: space {CrossSpace} with: regions {PtrArray unused of: XnRegion} with: expectedBoxCount {Int32} super create. mySpace := space. myRegions := PtrArray nulls: space axisCount * expectedBoxCount. myIndex := Int32Zero. Ravi shouldImplement. "shouldn't we be doing something with the 'regios' argument?"! ! !BoxAccumulator methodsFor: 'private:'! {void} aboutToAdd "Make sure there is room to add a box" myIndex * mySpace axisCount < myRegions count ifFalse: [myRegions := (myRegions copyGrow: (myIndex + 1) * mySpace axisCount) cast: PtrArray].! {Int32} addSubstitutedBox: current {Int32} with: dimension {Int32} with: newRegion {XnRegion} "Add a new box which is just like a current one except for the projection on one dimension. Return its index" self aboutToAdd. myRegions at: myIndex * mySpace axisCount storeMany: myRegions with: mySpace axisCount with: current * mySpace axisCount. myRegions at: myIndex * mySpace axisCount + dimension store: newRegion. myIndex := myIndex + 1. ^myIndex - 1! {Int32} boxCount self knownBug. "includes deleted boxes" ^myIndex! {XnRegion} boxProjection: box {Int32} with: dimension {Int32} "Change a projection of a box" ^(myRegions fetch: box * mySpace axisCount + dimension) cast: XnRegion! {void} deleteBox: box {Int32} "Mark a box as deleted" myRegions at: box * mySpace axisCount store: NULL! {BooleanVar} distributeUnion: added {Int32} with: start {Int32} with: stop {Int32} "Take my box at added and distribute it over my existing boxes from start to stop - 1 meanwhile taking pieces out of my box at remainder and delete it if it becomes empty Return true if there is still something left in the remainder" start almostTo: stop do: [ :index {Int32} | (self splitUnion: added with: index with: stop) ifFalse: [^false]]. ^true! {Int32} index ^myIndex! {BooleanVar} isDeleted: box {Int32} "Whether the box has been deleted" ^(myRegions fetch: box * mySpace axisCount) == NULL! {PtrArray of: XnRegion} secretRegions ^myRegions! {BooleanVar} splitUnion: added {Int32} with: current {Int32} with: stop {Int32} "Take my box at added and union it with my box at current delete it if it becomes empty Return true if there is still something left in the added box" | dimension {Int32} addedRegion {XnRegion} currentRegion {XnRegion} common {XnRegion} newAdded {Int32} extraCurrent {XnRegion} extraAdded {XnRegion} | (self isDeleted: current) ifTrue: [^true]. dimension := Int32Zero. [dimension + 1 < mySpace axisCount] whileTrue: ["see if the added intersects the current in this dimension" addedRegion := self boxProjection: added with: dimension. currentRegion := self boxProjection: current with: dimension. self thingToDo. "Add protocol for tri-delta: gives triple (a-b, a&b, b-a)" common := addedRegion intersect: currentRegion. common isEmpty ifTrue: [^true]. "split out the part of current that doesn't intersect" extraCurrent := currentRegion minus: common. extraCurrent isEmpty ifFalse: [self addSubstitutedBox: current with: dimension with: extraCurrent. self storeBoxProjection: current with: dimension with: common]. "split out the part of the added that doesn't intersect" extraAdded := addedRegion minus: common. extraAdded isEmpty ifFalse: [newAdded := self addSubstitutedBox: added with: dimension with: extraAdded. self distributeUnion: newAdded with: current + 1 with: stop. self storeBoxProjection: added with: dimension with: common]. dimension := dimension + 1]. "union the added into the last dimension of the current box" addedRegion := self boxProjection: added with: dimension. currentRegion := self boxProjection: current with: dimension. self storeBoxProjection: current with: dimension with: (currentRegion unionWith: addedRegion). self deleteBox: added. ^false! {void} storeBoxProjection: box {Int32} with: dimension {Int32} with: region {XnRegion} "Change a projection of a box" myRegions at: box * mySpace axisCount + dimension store: region! {void} tryMergeBoxes: i {Int32} with: j {Int32} "If two boxes differ by only one projection, union the second into the first and delete the second" | unequal {Int32} | unequal := -1. Int32Zero almostTo: mySpace axisCount do: [ :dim {Int32} | ((self boxProjection: i with: dim) isEqual: (self boxProjection: j with: dim)) ifFalse: [unequal >= Int32Zero ifTrue: [^VOID]. unequal := dim]]. self storeBoxProjection: i with: unequal with: ((self boxProjection: i with: unequal) unionWith: (self boxProjection: j with: unequal)). self deleteBox: j.! ! !BoxAccumulator methodsFor: 'operations'! {void} addAccumulatedBoxes: other {BoxAccumulator} "Add in all the boxes in another accumulator" Int32Zero almostTo: other index do: [ :box {Int32} | (other isDeleted: box) ifFalse: [self aboutToAdd. myRegions at: myIndex * mySpace axisCount storeMany: other secretRegions with: mySpace axisCount with: box * mySpace axisCount. myIndex := myIndex + 1]]! {Int32} addBox: box {BoxStepper} "Add the current box to the end of the array" ^self addProjections: box region secretRegions with: box boxIndex! {void} addInverseTransformedBox: box {BoxStepper} with: dsp {GenericCrossDsp} "Add the current box, transformed by the inverse of the dsp" | base {Int32} | self aboutToAdd. base := mySpace axisCount * myIndex. Int32Zero almostTo: mySpace axisCount do: [ :dimension {Int32} | myRegions at: base + dimension store: ((dsp subMapping: dimension) inverseOfAll: (box projection: dimension))]. myIndex := myIndex + 1.! {Int32} addProjections: projections {PtrArray of: XnRegion} with: boxIndex {Int32} "Add a box to the end of the array" self aboutToAdd. myRegions at: myIndex * mySpace axisCount storeMany: projections with: mySpace axisCount with: boxIndex * mySpace axisCount. myIndex := myIndex + 1. ^myIndex - 1! {void} addTransformedBox: box {BoxStepper} with: dsp {GenericCrossDsp} "Add the current box, transformed by the dsp" | base {Int32} | self aboutToAdd. base := myIndex * mySpace axisCount. Int32Zero almostTo: mySpace axisCount do: [ :dimension {Int32} | myRegions at: base + dimension store: ((dsp subMapping: dimension) ofAll: (box projection: dimension))]. myIndex := myIndex + 1.! {void} intersectWithBox: box {BoxStepper} "Intersect the current region with a box. May leave the result uncanonicalized" Int32Zero almostTo: myIndex do: [ :i {Int32} | (box intersectBoxInto: myRegions with: i) ifFalse: [self deleteBox: i]].! {void} mergeBoxes "merge boxes which differ in only one projection" Ravi thingToDo. "hash lookup" Int32Zero almostTo: myIndex do: [ :i {Int32} | (self isDeleted: i) ifFalse: [Int32Zero almostTo: myIndex do: [ :j {Int32} | (i == j or: [self isDeleted: j]) ifFalse: [self tryMergeBoxes: i with: j]]]]! {XnRegion} region "The current region in the accumulator. CLIENT MUST KNOW THAT IT IS CANONICAL" ^GenericCrossRegion make: mySpace with: myIndex with: ((myRegions copy: myIndex * mySpace axisCount) cast: PtrArray)! {void} removeDeleted "Remove boxes which have been deleted" | to {Int32} from {Int32} | from := to := Int32Zero. [from < myIndex] whileTrue: [(self isDeleted: from) ifFalse: [from > to ifTrue: [myRegions at: to * mySpace axisCount storeMany: myRegions with: mySpace axisCount with: from * mySpace axisCount]. to := to + 1]. from := from + 1]. myIndex := to! {void} step: someObj {Heaper} self unionWithBoxes: (someObj cast: GenericCrossRegion) boxStepper! {void} unionWithBox: box {BoxStepper} "Add the current box to the accumulator" | initialIndex {Int32} addedIndex {Int32} | initialIndex := myIndex. addedIndex := self addBox: box. self distributeUnion: addedIndex with: Int32Zero with: initialIndex.! {void} unionWithBoxes: boxes {BoxStepper} "Add a sequence of disjoint boxes to the accumulator" myIndex = Int32Zero ifTrue: [[boxes hasValue] whileTrue: [self addBox: boxes. boxes step]] ifFalse: [[boxes hasValue] whileTrue: [self unionWithBox: boxes. boxes step]]! {Heaper} value ^self region! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BoxAccumulator class instanceVariableNames: ''! (BoxAccumulator getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !BoxAccumulator class methodsFor: 'smalltalk: init'! initTimeNonInherited SomeAccumulators := InstanceCache make: 8! linkTimeNonInherited SomeAccumulators := NULL! ! !BoxAccumulator class methodsFor: 'creation'! make: region {GenericCrossRegion} | result {Heaper} | result := SomeAccumulators fetch. result == NULL ifTrue: [^ self create: region] ifFalse: [^ (self new.Become: result) create: region]! make: space {CrossSpace} with: expectedBoxCount {Int32} | result {Heaper} | result := SomeAccumulators fetch. result == NULL ifTrue: [^ self create: space with: expectedBoxCount] ifFalse: [^ (self new.Become: result) create: space with: expectedBoxCount]! !Accumulator subclass: #EdgeAccumulator instanceVariableNames: ' myManager {EdgeManager} myStartsInside {BooleanVar} myEdges {PtrArray of: TransitionEdge} myIndex {Int32} myPending {TransitionEdge} myResultGiven {BooleanVar NOCOPY}' classVariableNames: 'SomeAccumulators {InstanceCache} ' poolDictionaries: '' category: 'Xanadu-EdgeRegion'! (EdgeAccumulator getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !EdgeAccumulator methodsFor: 'protected: create'! create: manager {EdgeManager} with: startsInside {BooleanVar} super create. myManager := manager. myStartsInside := startsInside. myEdges := PtrArray nulls: 4. myIndex := -1. myPending := NULL. myResultGiven := false! create: manager {EdgeManager} with: startsInside {BooleanVar} with: edges {PtrArray of: TransitionEdge} with: index {Int32} with: pending {TransitionEdge} super create. myManager := manager. myStartsInside _ startsInside. myEdges _ edges. myIndex := index. myPending _ pending. myResultGiven := false! ! !EdgeAccumulator methodsFor: 'creation'! {Accumulator} copy | result {Heaper} | result := SomeAccumulators fetch. myResultGiven := true. result == NULL ifTrue: [ ^EdgeAccumulator create: myManager with: myStartsInside with: myEdges with: myIndex with: myPending] ifFalse: [ ^(EdgeAccumulator new.Become: result) create: myManager with: myStartsInside with: myEdges with: myIndex with: myPending]! {void} destroy (SomeAccumulators store: self) ifFalse: [super destroy]! ! !EdgeAccumulator methodsFor: 'operations'! {void} step: someObj {Heaper} self edge: (someObj cast: TransitionEdge)! {Heaper} value ^self region! ! !EdgeAccumulator methodsFor: 'edge operations'! {void} edge: x {TransitionEdge} "add a transition at the given position. doing it again cancels it" myPending == NULL ifTrue: [myPending := x] ifFalse: [(myPending isEqual: x) ifTrue: [myPending := NULL] ifFalse: [self storeStep: myPending. myPending := x]].! {void} edges: stepper {EdgeStepper} "add a whole bunch of edges at once, assuming that they are sorted and there are no duplicates" "do the first step manually in case it is the same as the current edge then do all the rest without checking for repeats" stepper hasValue ifTrue: [|edge {TransitionEdge} | self edge: stepper fetchEdge. stepper step. [(edge := stepper fetch cast: TransitionEdge) ~~ NULL] whileTrue: [ myPending ~~ NULL ifTrue: [self storeStep: myPending]. myPending := edge. stepper step]]! {XnRegion} region "make a region out of the accumulated edges" myPending ~~ NULL ifTrue: [self storeStep: myPending. myPending := NULL]. myResultGiven := true. ^myManager makeNew: myStartsInside with: myEdges with: myIndex + 1! ! !EdgeAccumulator methodsFor: 'private:'! {void} storeStep: edge {TransitionEdge} "Just store an edge into the array and increment the count" myIndex := myIndex + 1. myIndex = myEdges count ifTrue: [ myEdges := (myEdges copyGrow: myEdges count) cast: PtrArray. myResultGiven := false] ifFalse: [ myResultGiven ifTrue: [ myEdges := myEdges copy cast: PtrArray. myResultGiven := false]]. myEdges at: myIndex store: edge.! ! !EdgeAccumulator methodsFor: 'hooks:'! {void RECEIVE.HOOK} restartEdgeAccumulator: rcvr {Rcvr unused} myResultGiven := false! ! !EdgeAccumulator methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myManager _ receiver receiveHeaper. myStartsInside _ receiver receiveBooleanVar. myEdges _ receiver receiveHeaper. myIndex _ receiver receiveInt32. myPending _ receiver receiveHeaper. self restartEdgeAccumulator: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myManager. xmtr sendBooleanVar: myStartsInside. xmtr sendHeaper: myEdges. xmtr sendInt32: myIndex. xmtr sendHeaper: myPending.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! EdgeAccumulator class instanceVariableNames: ''! (EdgeAccumulator getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !EdgeAccumulator class methodsFor: 'smalltalk: init'! initTimeNonInherited SomeAccumulators := InstanceCache make: 8! linkTimeNonInherited SomeAccumulators := NULL! ! !EdgeAccumulator class methodsFor: 'create'! make: manager {EdgeManager} with: startsInside {BooleanVar} | result {Heaper} | result := SomeAccumulators fetch. result == NULL ifTrue: [^ self create: manager with: startsInside] ifFalse: [^ (self new.Become: result) create: manager with: startsInside]! !Accumulator subclass: #IntegerEdgeAccumulator instanceVariableNames: ' myStartsInside {BooleanVar} myEdges {IntegerVarArray} myIndex {UInt32} havePending {BooleanVar} myPending {IntegerVar}' classVariableNames: 'SomeAccumulators {InstanceCache} ' poolDictionaries: '' category: 'Xanadu-Spaces-Integers'! (IntegerEdgeAccumulator getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !IntegerEdgeAccumulator methodsFor: 'protected: creation'! create: startsInside {BooleanVar} with: count {UInt32} super create. myStartsInside _ startsInside. myEdges _ IntegerVarArray zeros: count. myIndex _ Int32Zero. havePending _ false. myPending _ IntegerVar0! create: startsInside {BooleanVar} with: edges {IntegerVarArray} with: index {UInt32} with: hasPending {BooleanVar} with: pending {IntegerVar} super create. myStartsInside _ startsInside. myEdges _ edges. myIndex _ index. havePending _ hasPending. myPending _ pending! ! !IntegerEdgeAccumulator methodsFor: 'creation'! {Accumulator} copy | result {Heaper} | result := SomeAccumulators fetch. result == NULL ifTrue: [ ^IntegerEdgeAccumulator create: myStartsInside with: myEdges with: myIndex with: havePending with: myPending] ifFalse: [ ^(IntegerEdgeAccumulator new.Become: result) create: myStartsInside with: myEdges with: myIndex with: havePending with: myPending]! {void} destroy (SomeAccumulators store: self) ifFalse: [super destroy]! ! !IntegerEdgeAccumulator methodsFor: 'operations'! {void} step: someObj {Heaper} self edge: (someObj cast: IntegerPos) asIntegerVar! {Heaper} value ^self region! ! !IntegerEdgeAccumulator methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '(' << self region << ')'! ! !IntegerEdgeAccumulator methodsFor: 'edge operations'! {void} edge: x {IntegerVar} "add a transition at the given position. doing it again cancels it. This particular coding is used for C++ inlinability" havePending ifTrue: [myPending = x ifTrue: [havePending _ false] ifFalse: [myEdges at: myIndex storeIntegerVar: myPending. myIndex _ myIndex + 1. myPending _ x]] ifFalse: [havePending _ true. myPending _ x].! {void} edges: stepper {IntegerEdgeStepper} "add a whole bunch of edges at once, assuming that they are sorted and there are no duplicates" stepper hasValue ifTrue: [self edge: stepper edge. stepper step. stepper hasValue ifTrue: [havePending ifFalse: [myPending _ stepper edge. havePending _ true. stepper step]. [stepper hasValue] whileTrue: [myEdges at: myIndex storeIntegerVar: myPending. myIndex _ myIndex + 1. myPending _ stepper edge. stepper step]]]! {IntegerRegion} region "make a region out of the accumulated edges" havePending ifTrue: [myEdges at: myIndex storeIntegerVar: myPending. ^IntegerRegion create: myStartsInside with: myIndex + 1 with: myEdges] ifFalse: [myIndex == Int32Zero ifTrue: [myStartsInside ifTrue: [^IntegerRegion allIntegers] ifFalse: [^IntegerRegion make]] ifFalse: [^IntegerRegion create: myStartsInside with: myIndex with: myEdges]]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! IntegerEdgeAccumulator class instanceVariableNames: ''! (IntegerEdgeAccumulator getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !IntegerEdgeAccumulator class methodsFor: 'creation'! make: startsInside {BooleanVar} with: count {UInt32} | result {Heaper} | result := SomeAccumulators fetch. result == NULL ifTrue: [^ self create: startsInside with: count] ifFalse: [^ (self new.Become: result) create: startsInside with: count]! ! !IntegerEdgeAccumulator class methodsFor: 'smalltalk: init'! initTimeNonInherited SomeAccumulators := InstanceCache make: 16! linkTimeNonInherited SomeAccumulators := NULL! !Accumulator subclass: #PtrArrayAccumulator instanceVariableNames: ' myValues {PtrArray} myN {UInt4} myValuesGiven {BooleanVar}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-aspire'! PtrArrayAccumulator comment: 'To save array copies, this class will hand out its internal array if the size is right. If it does so it remembers so that if new elements are introduced, a copy can be made for further use.'! (PtrArrayAccumulator getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !PtrArrayAccumulator methodsFor: 'operations'! {Accumulator} copy ^PtrArrayAccumulator create: (myValues copy cast: PtrArray) with: myN! {void} step: x {Heaper} myN + 1 < myValues count ifFalse: [myValues := (myValues copyGrow: myValues count+1) cast: PtrArray]. myValues at: myN store: x. myN := myN + 1.! {Heaper} value myValues count == myN ifTrue: [ myValuesGiven := true. ^ myValues] ifFalse: [ ^myValues copy: myN]! ! !PtrArrayAccumulator methodsFor: 'create'! create super create. myValues := PtrArray nulls: 2. myN := UInt32Zero. myValuesGiven := false! create: count {UInt32} super create. myValues := PtrArray nulls: count. myN := UInt32Zero. myValuesGiven := false! create: values {PtrArray} with: n {UInt32} super create. myValues := values. myN := n. myValuesGiven := false! !Accumulator subclass: #SetAccumulator instanceVariableNames: 'muSet {MuSet}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Sets'! SetAccumulator comment: 'A SetAccumulator accumulates a bunch of objects and then makes an ImmuSet containing all the accumulated objects. Several people have observed that a SetAccumulator doesn''t buy you much because instead you could just store into a MuSet. While this is true (and is in fact how SetAccumulator is trivially implemented), my feeling is that if what a loop is doing is enumerating a bunch of elements from which a Set is to be formed, using a SetAccumulator in the loops says this more clearly to readers of the code.'! (SetAccumulator getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !SetAccumulator methodsFor: 'accessing'! {void} step: someObj {Heaper} muSet store: someObj! {Heaper} value ^ muSet asImmuSet! ! !SetAccumulator methodsFor: 'protected: creation'! create super create. muSet _ MuSet make! create: initialSet {ScruSet} super create. muSet _ initialSet asMuSet! ! !SetAccumulator methodsFor: 'creation'! {Accumulator} copy ^ SetAccumulator create: muSet asMuSet! ! !SetAccumulator methodsFor: 'smalltalk: passe'! {ImmuSet} get self passe! ! !SetAccumulator methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. muSet _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: muSet.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! SetAccumulator class instanceVariableNames: ''! (SetAccumulator getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !SetAccumulator class methodsFor: 'instance creation'! {SetAccumulator} make "Make a SetAccumulator which starts out with no elements accumulated" ^SetAccumulator create! {SetAccumulator} make: initialSet {ScruSet} "Make a new SetAccumulator in which all the current elements of initialSet are already accumulated. Future changes to initialSet have no effect on the accumulator." ^SetAccumulator create: initialSet! !Accumulator subclass: #TableAccumulator instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Steppers'! TableAccumulator comment: 'Consider this class''s public status as obsolete. Eventually This class will either be private of get retired.'! (TableAccumulator getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !TableAccumulator methodsFor: 'deferred operations'! {void} step: elem {Heaper} "Add elem to the internal table." self subclassResponsibility! {Heaper} value "Return the accumulated table." self subclassResponsibility! ! !TableAccumulator methodsFor: 'deferred create'! {Accumulator} copy "Should this copy the array?" self subclassResponsibility! ! !TableAccumulator methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << ' on ' << self value! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TableAccumulator class instanceVariableNames: ''! (TableAccumulator getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !TableAccumulator class methodsFor: 'pseudoConstructors'! {TableAccumulator} make "Returns an Accumulator which will produce an MuArray of the elements accumulated into it in order of accumulation. See MuArray. Equivalent to 'arrayAccumulator()'. Eventually either he or I should be declared obsolete. INLINE" ^MuArray arrayAccumulator! !TableAccumulator subclass: #ArrayAccumulator instanceVariableNames: 'arrayInternal {MuArray}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Steppers'! (ArrayAccumulator getOrMakeCxxClassDescription) friends: 'friend class XuArray;'; attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !ArrayAccumulator methodsFor: 'protected: create'! create: onTable {MuArray} super create. arrayInternal _ onTable! ! !ArrayAccumulator methodsFor: 'operations'! {void} step: obj {Heaper} arrayInternal isEmpty ifTrue: [arrayInternal atInt: IntegerVar0 store: obj] ifFalse: [arrayInternal atInt: (arrayInternal domain quickCast: IntegerRegion) stop introduce: obj]! {Heaper} value ^ arrayInternal.! ! !ArrayAccumulator methodsFor: 'create'! {Accumulator} copy ^ ArrayAccumulator make: (arrayInternal copy cast: MuArray)! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ArrayAccumulator class instanceVariableNames: ''! (ArrayAccumulator getOrMakeCxxClassDescription) friends: 'friend class XuArray;'; attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !ArrayAccumulator class methodsFor: 'create'! {TableAccumulator} make: onTable {MuArray} ^ self create: onTable! ! !ArrayAccumulator class methodsFor: 'smalltalk: creation'! create.IntegerTable: aTable ^self new create: aTable! !Accumulator subclass: #UnionRecruiter instanceVariableNames: 'muSet {MuSet}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Sets'! UnionRecruiter comment: 'Like a SetAccumulator, a UnionRecruiter makes an ImmuSet out of the things that it Accumulates. However, the things that a UnionRecruiter accumulates must themselves be ScruSets, and the resulting ImmuSet consists of the union of the elements of each of the accumulated sets as of the time they were accumulated.'! (UnionRecruiter getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !UnionRecruiter methodsFor: 'accessing'! {void} step: someObj {Heaper} muSet storeAll: (someObj cast: ScruSet)! {Heaper} value ^ muSet asImmuSet! ! !UnionRecruiter methodsFor: 'protected: creation'! create super create. muSet _ MuSet make! ! !UnionRecruiter methodsFor: 'creation'! {Accumulator} copy | result {Accumulator} | result _ UnionRecruiter make. result step: muSet. ^result! ! !UnionRecruiter methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. muSet _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: muSet.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! UnionRecruiter class instanceVariableNames: ''! (UnionRecruiter getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !UnionRecruiter class methodsFor: 'pseudo constructors'! {UnionRecruiter} make "Make a new UnionRecruiter which hasn't yet accumulated anything" ^UnionRecruiter create! !Heaper subclass: #Arrangement instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-arrange'! Arrangement comment: 'Generally represents a pair of an OrderSpec and a Region. Arrangements map between regions and primArrays.'! (Arrangement getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #COPY; yourself)! !Arrangement methodsFor: 'accessing'! {void} copyElements: toArray {PrimArray} with: toDsp {Dsp} with: fromArray {PrimArray} with: fromArrange {Arrangement} with: fromRegion {XnRegion} "Copy elements into toArray arranged according to the receiver. Copy them from fromArray arranged according to fromArrange. The source region is fromRegion. It gets tranformed by toDsp into the toArray." fromRegion stepper forEach: [:key {Position} | toArray at: (self indexOf: (toDsp of: key)) DOTasLong storeValue: (fromArray fetchValue: (fromArrange indexOf: key) DOTasLong)]! {IntegerVar} indexOf: position {Position unused} "Return the index of position into my Region according to my OrderSpec." self subclassResponsibility! {IntegerRegion} indicesOf: region {XnRegion} "Return the region of all the indices corresponding to positions in region." self subclassResponsibility! {XnRegion} keysOf: start {Int32} with: stop {Int32} "Return the region that corresponds to a range of indices." self subclassResponsibility! {XnRegion} region "The region of positions in the arrangement" self subclassResponsibility! ! !Arrangement methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! ! !Arrangement methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !Arrangement subclass: #ExplicitArrangement instanceVariableNames: 'myPositions {PtrArray of: Position}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-tumbler'! (ExplicitArrangement getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !ExplicitArrangement methodsFor: 'create'! create: positions {PtrArray of: Position} super create. myPositions := positions.! ! !ExplicitArrangement methodsFor: 'accessing'! {IntegerVar} indexOf: position {Position} Int32Zero almostTo: myPositions count do: [ :i {Int32} | (position isEqual: (myPositions fetch: i)) ifTrue: [^i]]. Heaper BLAST: #NotFound. ^ -1 "compiler fodder"! {IntegerRegion} indicesOf: region {XnRegion} | result {IntegerRegion} | result := IntegerRegion make. Int32Zero almostTo: myPositions count do: [ :i {Int32} | (region hasMember: ((myPositions fetch: i) cast: Position)) ifTrue: [result := (result with: i integer) cast: IntegerRegion]]. ^result! {XnRegion} keysOf: start {Int32} with: stop {Int32} | result {XnRegion} | result := NULL. start almostTo: stop do: [ :i {Int32} | result == NULL ifTrue: [result := ((myPositions fetch: i) cast: Position) asRegion] ifFalse: [result := result with: ((myPositions fetch: i) cast: Position)]]. result == NULL ifTrue: [Heaper BLAST: #IndexOutOfBounds]. ^result! {XnRegion} region | result {XnRegion} | result := (myPositions get: Int32Zero) cast: XnRegion. 1 almostTo: myPositions count do: [ :i {Int32} | result := result with: ((myPositions get: i) cast: Position)]. ^result! ! !ExplicitArrangement methodsFor: 'testing'! {UInt32} actualHashForEqual ^ myPositions contentsHash! {UInt32} hashForEqual ^ myPositions contentsHash! {BooleanVar} isEqual: other {Heaper} other cast: ExplicitArrangement into: [:o {ExplicitArrangement} | ^ myPositions contentsEqual: o positions] others: [^ false ]. ^ false "fodder"! ! !ExplicitArrangement methodsFor: 'private: accessing'! {PtrArray} positions ^ myPositions! ! !ExplicitArrangement methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myPositions _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myPositions.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ExplicitArrangement class instanceVariableNames: ''! (ExplicitArrangement getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !ExplicitArrangement class methodsFor: 'create'! {Arrangement} make: positions {PtrArray of: Position} ^self create: positions! !Arrangement subclass: #IntegerArrangement instanceVariableNames: ' myOrdering {OrderSpec} myRegion {IntegerRegion}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Spaces-Integers'! (IntegerArrangement getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !IntegerArrangement methodsFor: 'accessing'! {void} copyElements: toArray {PrimArray} with: toDsp {Dsp} with: fromArray {PrimArray} with: fromArrange {Arrangement} with: fromRegion {XnRegion} | other {IntegerArrangement} start {Int32} stop {Int32} toStart {Int32} | other _ fromArrange cast: IntegerArrangement. (myOrdering isEqual: other ordering) ifFalse: [self unimplemented]. (myRegion isSimple and: [other region isSimple and: [fromRegion isSimple]]) ifFalse: [self unimplemented]. self knownBug. "Assume ascending for the moment." start _ (fromArrange indexOf: (fromRegion chooseOne: myOrdering)) DOTasLong. stop _ (fromArrange indexOf: (fromRegion chooseOne: myOrdering reversed)) DOTasLong. toStart _ (self indexOf: (toDsp of: (fromRegion chooseOne: myOrdering))) DOTasLong. "stop < start ifTrue: [| tmp {Int32} | tmp _ start. start _ stop. stop _ tmp]." toArray at: toStart storeMany: fromArray with: stop + 1 - start with: start! {IntegerVar} indexOf: position {Position} "Return the index of position into my Region according to my OrderSpec." | sum {IntegerVar} intPos {IntegerVar} | sum _ IntegerVar0. intPos _ (position cast: IntegerPos) asIntegerVar. (myRegion simpleRegions: myOrdering) forEach: [:region {IntegerRegion} | (region hasIntMember: intPos) ifTrue: [^sum + (intPos - ((region chooseOne: myOrdering) cast: IntegerPos) asIntegerVar) abs] ifFalse: [sum _ sum + region count]]. Heaper BLAST: #NotInTable. ^ -1 "compiler fodder"! {IntegerRegion} indicesOf: region {XnRegion} "Return the region of all the indices corresponding to positions in region." Someone shouldImplement. ^NULL "fodder"! {XnRegion} keysOf: start {Int32} with: stop {Int32} "Return the region that corresponds to a range of indices." | offset {Int32} left {Int32} right {Int32} | offset _ start. left _ -1. (myRegion simpleRegions: myOrdering) forEach: [:region {XnRegion} | region count <= offset ifTrue: [offset _ offset - region count DOTasLong] ifFalse: [left == -1 ifTrue: [left _ ((region chooseOne: myOrdering) cast: IntegerPos) asIntegerVar DOTasLong + offset. offset _ stop - (start - offset). offset <= region count DOTasLong ifTrue: [^IntegerRegion make: left with: (((region chooseOne: myOrdering) cast: IntegerPos) asIntegerVar + offset)]] ifFalse: [right _ ((region chooseOne: myOrdering) cast: IntegerPos) asIntegerVar DOTasLong + offset. ^IntegerRegion make: left with: right]]]. Heaper BLAST: #NotInTable. ^ NULL "compiler fodder"! {OrderSpec} ordering ^myOrdering! {XnRegion} region ^myRegion! ! !IntegerArrangement methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '(' << myRegion << ', ' << myOrdering << ')'! ! !IntegerArrangement methodsFor: 'protected: creation'! create: region {XnRegion} with: ordering {OrderSpec} super create. region isFinite ifFalse: [Heaper BLAST: #MustBeFinite]. myRegion _ region cast: IntegerRegion. myOrdering _ ordering! ! !IntegerArrangement methodsFor: 'testing'! {UInt32} actualHashForEqual ^ myOrdering hashForEqual + myRegion hashForEqual! {UInt32} hashForEqual ^ myOrdering hashForEqual + myRegion hashForEqual! {BooleanVar} isEqual: other {Heaper} other cast: IntegerArrangement into: [:o {IntegerArrangement} | ^ (myOrdering isEqual: o ordering) and: [myRegion isEqual: o region]] others: [^ false]. ^ false "fodder"! ! !IntegerArrangement methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myOrdering _ receiver receiveHeaper. myRegion _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myOrdering. xmtr sendHeaper: myRegion.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! IntegerArrangement class instanceVariableNames: ''! (IntegerArrangement getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !IntegerArrangement class methodsFor: 'creation'! make: region {XnRegion} with: ordering {OrderSpec} ^self create: region with: ordering! !Heaper subclass: #BeCarrier instanceVariableNames: ' myLabel {BeLabel | NULL} myRangeElement {BeRangeElement}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Basic'! BeCarrier comment: 'These are used to carry a combination of a rangeElement and a label. Using FeRangeElements would be a hack that drags in permissions checking, etc.'! (BeCarrier getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !BeCarrier methodsFor: 'accessing'! {BeLabel | NULL} fetchLabel ^myLabel! {BeLabel} getLabel myLabel == NULL ifTrue: [Heaper BLAST: #NoLabel]. ^myLabel! {FeRangeElement} makeFe myLabel == NULL ifTrue: [^myRangeElement makeFe: myLabel] ifFalse: [^myRangeElement makeFe: myLabel]! {BeRangeElement} rangeElement ^myRangeElement! ! !BeCarrier methodsFor: 'creation'! create: label {BeLabel | NULL} with: element {BeRangeElement} super create. myLabel _ label. myRangeElement _ element. (myLabel ~~ NULL) == (myRangeElement isKindOf: BeEdition) ifFalse: [Heaper BLAST: #IncorrectLabel]! ! !BeCarrier methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BeCarrier class instanceVariableNames: ''! (BeCarrier getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !BeCarrier class methodsFor: 'creation'! {BeCarrier} label: element {BeRangeElement} "For non-Editions only." [BeGrandMap] USES. ^self create: (CurrentGrandMap fluidGet newLabel) with: element! make: element {BeRangeElement} "For non-Editions only." ^self create: NULL with: element! make: label {BeLabel | NULL} with: element {BeRangeElement} "For editions only." ^self create: label with: element! !XnExecutor subclass: #BeEditionDetectorExecutor instanceVariableNames: 'myEdition {BeEdition}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-brange3'! BeEditionDetectorExecutor comment: 'This class notifies its edition when its last detector has gone.'! (BeEditionDetectorExecutor getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !BeEditionDetectorExecutor methodsFor: 'protected: create'! create: edition {BeEdition} super create. myEdition := edition.! ! !BeEditionDetectorExecutor methodsFor: 'execute'! {void} execute: arg {Int32} arg == Int32Zero ifTrue: [ myEdition removeLastDetector].! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BeEditionDetectorExecutor class instanceVariableNames: ''! (BeEditionDetectorExecutor getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !BeEditionDetectorExecutor class methodsFor: 'creation'! {XnExecutor} make: edition {BeEdition} ^ self create: edition! !XnExecutor subclass: #BeWorkLockExecutor instanceVariableNames: 'myWork {BeWork}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-brange2'! (BeWorkLockExecutor getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !BeWorkLockExecutor methodsFor: 'invoking'! {void} execute: estateIndex {Int32 unused} "The work's locking pointer will already be NULL, so we only have to update" myWork updateFeStatus! ! !BeWorkLockExecutor methodsFor: 'create'! create: work {BeWork} super create. myWork := work! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BeWorkLockExecutor class instanceVariableNames: ''! (BeWorkLockExecutor getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !BeWorkLockExecutor class methodsFor: 'pseudoconstructors'! make: work {BeWork} ^ BeWorkLockExecutor create: work! !Heaper subclass: #ByteShuffler instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! ByteShuffler comment: 'Instances shuffle bytes to convert between byte sexes. Subclasses are defined for each of the various transformations.'! (ByteShuffler getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !ByteShuffler methodsFor: 'shuffle'! {ByteShuffler} inverse "Return a shuffler that inverts the receiver's shuffler. This will typically be the same transformation." ^self! {void} shuffle: precision {Int32} with: buffer {void star} with: size {Int32} "Go from one byte sex to another for representing numbers of the specified precision." precision == 8 ifTrue: [^VOID]. precision == 16 ifTrue: [self shuffle16: buffer with: size. ^VOID]. precision == 32 ifTrue: [self shuffle32: buffer with: size. ^VOID]. precision == 64 ifTrue: [self shuffle64: buffer with: size. ^VOID]. Heaper BLAST: #BadPrecision! ! !ByteShuffler methodsFor: 'private: shuffle'! {void} shuffle16: buffer {void star} with: count {Int32} "Go from one byte sex to another for representing 16 bit numbers." self subclassResponsibility! {void} shuffle32: buffer {void star} with: count {Int32} "Go from one byte sex to another for representing 32 bit numbers." self subclassResponsibility! {void} shuffle64: buffer {void star} with: count {Int32} "Go from one byte sex to another for representing 64 bit numbers." self subclassResponsibility! ! !ByteShuffler methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! !ByteShuffler subclass: #NoShuffler instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! NoShuffler comment: 'No transformation.'! (NoShuffler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !NoShuffler methodsFor: 'shuffle'! {void} shuffle16: buffer {void star} with: count {Int32} "Do nothing."! {void} shuffle32: buffer {void star} with: count {Int32} "Do nothing."! {void} shuffle64: buffer {void star} with: count {Int32} "Do nothing."! !ByteShuffler subclass: #SimpleShuffler instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! SimpleShuffler comment: 'shuffle big-endian to little-endian transformation.'! (SimpleShuffler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !SimpleShuffler methodsFor: 'shuffle'! {void} shuffle16: buffer {void star} with: count {Int32} " shuffle alternating bytes. " [0 almostTo: count * 2 by: 2 do: [:index | | temp {Uint8} | temp _ buffer at: index. buffer at: index storeUInt: (buffer at: index + 1). buffer at: index + 1 storeUInt: temp]] smalltalkOnly. 'UInt8 temp; UInt8 * base = (UInt8 *) buffer; for (Int32 index = 0 ; index < count * 2 ; index += 2) { temp = base[index]; base[index] = base[index + 1]; base[index + 1] = temp; } ' translateOnly.! {void} shuffle32: buffer {void star} with: count {Int32} " shuffle alternating words. " [0 almostTo: count * 4 by: 4 do: [:index | | temp {UInt8} | temp _ buffer at: index. buffer at: index storeUInt: (buffer at: index + 3). buffer at: index + 3 storeUInt: temp. temp _ buffer at: index + 1. buffer at: index + 1 storeUInt: (buffer at: index + 2). buffer at: index + 2 storeUInt: temp. ]] smalltalkOnly. 'UInt8 temp; UInt8 * base = (UInt8 *) buffer; for (Int32 index = 0 ; index < count * 4; index += 4) { temp = base[index]; base[index] = base[index + 3]; base[index + 3] = temp; temp = base[index + 1]; base[index + 1] = base[index + 2]; base[index + 2] = temp; }' translateOnly.! {void} shuffle64: buffer {void star} with: count {Int32} self unimplemented.! !Heaper subclass: #CacheManager instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-cache'! (CacheManager getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !CacheManager methodsFor: 'accessing'! {Heaper | NULL} fetch: key {Heaper} "Return the value associated with the key, if any." self subclassResponsibility! {BooleanVar} hasMember: key {Heaper} "Does te cach contain something at the given key?" "Should the key be a Heaper or a Position?" self subclassResponsibility! {BooleanVar} wipe: key {Heaper} "Remove the cached association with key. Return true if the cache contained something at that key." self subclassResponsibility! ! !CacheManager methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! !Heaper subclass: #CanopyCache instanceVariableNames: ' myCachedCrum {CanopyCrum} myCachedRoot {CanopyCrum} myCachedPath {MuSet of: CanopyCrum}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Canopy'! (CanopyCache getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !CanopyCache methodsFor: 'protected: creation'! create super create. myCachedCrum _ NULL. myCachedRoot _ NULL. myCachedPath _ MuSet make! ! !CanopyCache methodsFor: 'operations'! {void} clearCache "Clear the cache because the canopy has changed. This ought to destroy the cachedPath. This must be cleared after every episode!!!!!!" myCachedCrum _ NULL. myCachedRoot _ NULL. myCachedPath _ MuSet make.! {MuSet of: CanopyCrum} pathFor: canopyCrum {CanopyCrum} "Return the set of all crums from canopyCrum (inclusive) to the top of canopyCrum's canopy." (myCachedCrum basicCast: Heaper star) == canopyCrum ifFalse: [| cur {CanopyCrum} | cur _ canopyCrum. myCachedCrum _ canopyCrum. myCachedRoot _ canopyCrum. myCachedPath _ MuSet make. [cur ~~ NULL] whileTrue: [myCachedRoot _ cur. myCachedPath store: cur. cur _ cur fetchParent]]. ^myCachedPath! {CanopyCrum} rootFor: bertCrum {CanopyCrum} "Return the crum at the top of canopyCrum's canopy." self pathFor: bertCrum. ^myCachedRoot! {void} updateCache: childCrum {CanopyCrum} forParent: parentCrum {CanopyCrum} "If the cache contains childCrum it must be made to contain childCrum's new parent: parentCrum. Also update CachedRoot." (myCachedPath hasMember: childCrum) ifTrue: [myCachedPath store: parentCrum. (myCachedRoot basicCast: Heaper star) == childCrum ifTrue: [myCachedRoot _ parentCrum]]! {void} updateCacheFor: canopyCrum {CanopyCrum} "If the cache contains canopyCrum, it must be updated because canopyCrum has new parents. For now, just invalidate the cache." (myCachedCrum basicCast: Heaper star) == canopyCrum ifTrue: [self clearCache]! ! !CanopyCache methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CanopyCache class instanceVariableNames: ''! (CanopyCache getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !CanopyCache class methodsFor: 'make'! make ^ self create! !XnExecutor subclass: #Cattleman instanceVariableNames: 'myPasture {DiskManager}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-diskman'! Cattleman comment: 'Remove flocks from the snarfpacker'! (Cattleman getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !Cattleman methodsFor: 'create'! create: dm {DiskManager} super create. myPasture := dm! ! !Cattleman methodsFor: 'invoking'! {void} execute: token {Int32} "[Drops add: token] smalltalkOnly." (Heaper isConstructed: myPasture) ifTrue: [ [Heaper setGC: true] smalltalkOnly. myPasture dropFlock: token. [Heaper setGC: false] smalltalkOnly]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Cattleman class instanceVariableNames: ''! (Cattleman getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !Cattleman class methodsFor: 'create'! make: dm {DiskManager} ^ self create: dm! !Heaper subclass: #CBlockTracker instanceVariableNames: ' myFileName {char star | NULL} myLineNo {Int4} myMaxDirty {IntegerVar} myLimit {IntegerVar} myDirtySoFar {IntegerVar} myTrulyDirtySoFar {IntegerVar} myDirtyInfos {MuSet of: IntegerPos} myDirtyInfosCount {IntegerVar} myOuterTracker {CBlockTracker | NULL} myOccurencesCount {IntegerVar}' classVariableNames: 'TheTrackerList {CBlockTracker | NULL} ' poolDictionaries: '' category: 'Xanadu-Snarf'! (CBlockTracker getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !CBlockTracker methodsFor: 'creation'! create: dirty {IntegerVar} with: outer {CBlockTracker | NULL} super create. dirty = -1 ifTrue: [myMaxDirty _ 1000] ifFalse: [myMaxDirty _ dirty]. myOuterTracker _ outer. myFileName _ NULL. myLineNo _ Int32Zero. myDirtySoFar _ Int32Zero. myTrulyDirtySoFar _ Int32Zero. myDirtyInfos _ MuSet make. myDirtyInfosCount _ Int32Zero. myOccurencesCount _ 1. outer == NULL ifTrue: [myLimit _ myMaxDirty] ifFalse: [myLimit _ outer slack min: myMaxDirty]! ! !CBlockTracker methodsFor: 'accessing'! {void} dirty: info {FlockInfo | NULL} myDirtySoFar _ myDirtySoFar + 1. myTrulyDirtySoFar _ myTrulyDirtySoFar + 1. (info ~~ NULL) assert. myDirtyInfos store: (IntegerPos make: info getShepherd hashForEqual). myDirtyInfosCount _ myDirtyInfos count. self reportProblems! {CBlockTracker | NULL} fetchUnwrapped | result {CBlockTracker | NULL} stored {CBlockTracker | NULL} | result _ myOuterTracker. result ~~ NULL ifTrue: [result innerDirtied: myMaxDirty. result innerTrulyDirtied: myTrulyDirtySoFar. result innerDirtyInfos: myDirtyInfos. result reportProblems]. myFileName ~~ NULL ifTrue: [(TheTrackerList == NULL or: [(stored _ TheTrackerList fetchMatch: self) == NULL]) ifTrue: [myOuterTracker _ TheTrackerList. myDirtyInfos _ MuSet make. TheTrackerList _ self] ifFalse: [stored updateFrom: self]]. ^result! {void} track: fileName {char star} with: lineNo {Int32} myFileName _ fileName. myLineNo _ lineNo.! ! !CBlockTracker methodsFor: 'printing'! {void} printAllOn: oo {ostream reference} oo << self << ' '. myOuterTracker ~~ NULL ifTrue: [myOuterTracker printAllOn: oo]! {void} printOn: oo {ostream reference} oo << '"' << myFileName << '"' << ', line ' << myLineNo << ': ' << self getCategory name << '('. oo << myMaxDirty << ', ' << myLimit << ', ' << myDirtySoFar << ', ' << myTrulyDirtySoFar << ', ' << myDirtyInfosCount << ', ' << myOccurencesCount << ')'! ! !CBlockTracker methodsFor: 'private: accessing'! {IntegerVar} dirtyInfosCount ^myDirtyInfosCount! {IntegerVar} dirtySoFar ^myDirtySoFar! {CBlockTracker | NULL} fetchMatch: other {CBlockTracker} (myFileName ~~ NULL and: [other fileName ~~ NULL and: [(String strcmp: myFileName with: other fileName) = Int32Zero and: [myLineNo = other lineNo]]]) ifTrue: [^self] ifFalse: [myOuterTracker == NULL ifTrue: [^NULL] ifFalse: [^myOuterTracker fetchMatch: other]]! {char star | NULL} fileName ^myFileName! {void} innerDirtied: dirty {IntegerVar} myDirtySoFar _ myDirtySoFar + dirty! {void} innerDirtyInfos: dirties {MuSet of: IntegerPos} myDirtyInfos storeAll: dirties. myDirtyInfosCount _ myDirtyInfos count! {void} innerTrulyDirtied: dirty {IntegerVar} myTrulyDirtySoFar _ myTrulyDirtySoFar + dirty! {IntegerVar} limit ^myLimit! {Int32} lineNo ^myLineNo! {IntegerVar} maxDirty ^myMaxDirty! {IntegerVar} occurencesCount ^ myOccurencesCount! {void} reportProblems ^VOID "(myLimit < 1000 and: [myDirtyInfosCount > myMaxDirty ""((myDirtySoFar max: myTrulyDirtySoFar) max: myDirtyInfosCount) > myLimit""]) ifTrue: [cerr << ' Limit exceeded [ '. self printAllOn: cerr. [cerr endEntry. ""myDirtyInfosCount > myMaxDirty ifTrue: [self halt]""] smalltalkOnly]"! {IntegerVar} slack ^myLimit - myDirtySoFar! {IntegerVar} trulyDirtySoFar ^myTrulyDirtySoFar! {void} updateFrom: other {CBlockTracker} myMaxDirty _ myMaxDirty max: other maxDirty. myLimit _ myLimit min: other limit. myDirtySoFar _ myDirtySoFar max: other dirtySoFar. myTrulyDirtySoFar _ myTrulyDirtySoFar max: other trulyDirtySoFar. myDirtyInfosCount _ myDirtyInfosCount max: other dirtyInfosCount. myOccurencesCount _ myOccurencesCount + other occurencesCount! ! !CBlockTracker methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CBlockTracker class instanceVariableNames: ''! (CBlockTracker getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !CBlockTracker class methodsFor: 'creation'! make: dirty {IntegerVar} with: outer {CBlockTracker | NULL} ^self create: dirty with: outer! ! !CBlockTracker class methodsFor: 'smalltalk: init'! linkTimeNonInherited TheTrackerList _ NULL! ! !CBlockTracker class methodsFor: 'printing'! {void} printTrackersOn: oo {ostream reference} "CBlockTracker printTrackersOn: cerr. cerr endEntry" oo << ' Consistent-Block Behavior '. TheTrackerList ~~ NULL ifTrue: [TheTrackerList printAllOn: oo]. oo << ' '.! !Heaper subclass: #Chameleon instanceVariableNames: ' myA {IntegerVar} myB {Heaper} myC {BooleanVar}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Chameleon'! (Chameleon getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !Chameleon methodsFor: 'instance creation'! create super create. myA _ IntegerVar0. myB _ NULL. myC _ false.! create: a {IntegerVar} with: b {Heaper} with: c {BooleanVar} super create. myA _ a. myB _ b. myC _ c.! ! !Chameleon methodsFor: 'accessing'! {void} explain: oo {ostream reference} oo << self getCategory name << ' '.! ! !Chameleon methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! ! !Chameleon methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myA _ receiver receiveIntegerVar. myB _ receiver receiveHeaper. myC _ receiver receiveBooleanVar.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendIntegerVar: myA. xmtr sendHeaper: myB. xmtr sendBooleanVar: myC.! !Chameleon subclass: #Butterfly instanceVariableNames: ' myE {IntegerVar} myF {Heaper}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Chameleon'! (Butterfly getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !Butterfly methodsFor: 'instance creation'! create super create. myE _ IntegerVar0. myF _ NULL.! ! !Butterfly methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myE _ receiver receiveIntegerVar. myF _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendIntegerVar: myE. xmtr sendHeaper: myF.! !Butterfly subclass: #GoldButterfly instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Chameleon'! (GoldButterfly getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)!Butterfly subclass: #IronButterfly instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Chameleon'! (IronButterfly getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(MAY.BECOME.ANY.SUBCLASS.OF Chameleon ); yourself)!Butterfly subclass: #LeadButterfly instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Chameleon'! (LeadButterfly getOrMakeCxxClassDescription) attributes: ((Set new) add: #(MAY.BECOME DeadMoth ); add: #(MAY.BECOME Butterfly ); add: #CONCRETE; yourself)!Chameleon subclass: #DeadButterfly instanceVariableNames: ' myJ {IntegerVar} myK {Heaper} myL {Heaper} myM {Heaper}' classVariableNames: '' poolDictionaries: '' category: 'Cxx-class-stuff'! (DeadButterfly getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !DeadButterfly methodsFor: 'instance creation'! create super create. myJ _ IntegerVar0. myK _ NULL.! ! !DeadButterfly methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myJ _ receiver receiveIntegerVar. myK _ receiver receiveHeaper. myL _ receiver receiveHeaper. myM _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendIntegerVar: myJ. xmtr sendHeaper: myK. xmtr sendHeaper: myL. xmtr sendHeaper: myM.! !Chameleon subclass: #DeadMoth instanceVariableNames: ' myG {IntegerVar} myH {Heaper} myI {BooleanVar}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Chameleon'! (DeadMoth getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !DeadMoth methodsFor: 'instance creation'! create super create. myG _ IntegerVar0. myH _ NULL. myI _ false.! ! !DeadMoth methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myG _ receiver receiveIntegerVar. myH _ receiver receiveHeaper. myI _ receiver receiveBooleanVar.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendIntegerVar: myG. xmtr sendHeaper: myH. xmtr sendBooleanVar: myI.! !Chameleon subclass: #Moth instanceVariableNames: 'myD {IntegerVar}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Chameleon'! (Moth getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(MAY.BECOME Butterfly ); add: #COPY; yourself)! !Moth methodsFor: 'becoming'! {void} molt (Butterfly new.Become: self) create! ! !Moth methodsFor: 'instance creation'! create: d {IntegerVar} super create. myD _ d.! ! !Moth methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myD _ receiver receiveIntegerVar.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendIntegerVar: myD.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Moth class instanceVariableNames: ''! (Moth getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(MAY.BECOME Butterfly ); add: #COPY; yourself)! !Moth class methodsFor: 'instance creation'! make ^self create: 4! !Heaper subclass: #ChunkCleaner instanceVariableNames: 'myNext {ChunkCleaner}' classVariableNames: 'FirstCleaner {ChunkCleaner} ' poolDictionaries: '' category: 'Xanadu-schunk'! ChunkCleaner comment: 'Chunk cleaners perform end-of-session cleanup work. This includes making sure that session level objects are released.'! (ChunkCleaner getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #EQ; yourself)! !ChunkCleaner methodsFor: 'private: accessing'! {ChunkCleaner} next ^ myNext! ! !ChunkCleaner methodsFor: 'invoking'! {void} cleanup self subclassResponsibility! ! !ChunkCleaner methodsFor: 'protected: create'! create super create. myNext := FirstCleaner. FirstCleaner := self.! ! !ChunkCleaner methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ChunkCleaner class instanceVariableNames: ''! (ChunkCleaner getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #EQ; yourself)! !ChunkCleaner class methodsFor: 'cleanup'! {void} beClean | cleaner {ChunkCleaner} | cleaner := FirstCleaner. [cleaner ~~ NULL] whileTrue: [ cleaner cleanup. cleaner := cleaner next].! ! !ChunkCleaner class methodsFor: 'smalltalk: init'! linkTimeNonInherited FirstCleaner := NULL! !ChunkCleaner subclass: #PersistentCleaner instanceVariableNames: '' classVariableNames: 'ThePersistentCleaner {PersistentCleaner} ' poolDictionaries: '' category: 'Xanadu-packer'! PersistentCleaner comment: 'This does a makePersistent when ServerChunks go away'! (PersistentCleaner getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !PersistentCleaner methodsFor: 'invoking'! {void} cleanup CurrentPacker fluidGet purge! ! !PersistentCleaner methodsFor: 'protected: create'! create super create! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PersistentCleaner class instanceVariableNames: ''! (PersistentCleaner getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !PersistentCleaner class methodsFor: 'smalltalk: init'! linkTimeNonInherited ThePersistentCleaner := NULL! ! !PersistentCleaner class methodsFor: 'create'! make ThePersistentCleaner == NULL ifTrue: [ThePersistentCleaner := self create]. ^ ThePersistentCleaner! !XnExecutor subclass: #CloseExecutor instanceVariableNames: '' classVariableNames: ' FDArray {Int32Array} FileDescriptorHolders {WeakPtrArray} ' poolDictionaries: '' category: 'Xanadu-gchooks'! CloseExecutor comment: 'This executor manages objects that need to close file descriptors on finalization.'! (CloseExecutor getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; add: #NOT.A.TYPE; yourself)! !CloseExecutor methodsFor: 'protected: create'! create super create! ! !CloseExecutor methodsFor: 'invoking'! {void} execute: estateIndex {Int32} | fd {Int32} | fd := FDArray intAt: estateIndex. fd ~= -1 ifTrue: [ [fd close] smalltalkOnly. 'close((int)fd);' translateOnly. FDArray at: estateIndex storeInt: -1]! ! !CloseExecutor methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CloseExecutor class instanceVariableNames: ''! (CloseExecutor getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; add: #NOT.A.TYPE; yourself)! !CloseExecutor class methodsFor: 'accessing'! {void} registerHolder: holder {Heaper} with: fd {Int32} | slot {Int32} | slot _Int32Zero. FDArray == NULL ifTrue: [ | exec {XnExecutor} | FDArray := Int32Array make: 32. exec := CloseExecutor create. FileDescriptorHolders := WeakPtrArray make: exec with: 32]. slot := FileDescriptorHolders indexOf: NULL. [self halt.] smalltalkOnly. slot == -1 ifTrue: [ [self halt]smalltalkOnly. slot := FDArray count. FDArray := (FDArray copyGrow: 16) cast: Int32Array. FileDescriptorHolders := (FileDescriptorHolders copyGrow: 16) cast: WeakPtrArray]. FDArray at: slot storeInt: fd. FileDescriptorHolders at: slot store: holder.! {void} unregisterHolder: holder {Heaper} with: fd {Int32} | slot {Int32} | slot := FileDescriptorHolders indexOfEQ: holder. [slot ~= -1 and: [slot < FDArray count and: [(FDArray intAt: slot) ~= fd]]] whileTrue: [ slot := FileDescriptorHolders indexOfEQ: holder with: slot + 1]. (slot == -1 or: [(FDArray intAt: slot) ~= fd]) ifTrue: [ Heaper BLAST: #SanityViolation]. FileDescriptorHolders at: slot store: NULL. FDArray at: slot storeInt: -1.! ! !CloseExecutor class methodsFor: 'smalltalk: init'! linkTimeNonInherited FDArray := NULL. FileDescriptorHolders := NULL! !Heaper subclass: #CommIbid instanceVariableNames: 'myNumber {IntegerVar}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Xcvr'! (CommIbid getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !CommIbid methodsFor: 'creation'! create: number {IntegerVar} super create. myNumber _ number.! ! !CommIbid methodsFor: 'accessing'! {IntegerVar} number ^myNumber! ! !CommIbid methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '(' << myNumber << ')'.! ! !CommIbid methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! ! !CommIbid methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myNumber _ receiver receiveIntegerVar.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendIntegerVar: myNumber.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CommIbid class instanceVariableNames: ''! (CommIbid getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !CommIbid class methodsFor: 'creation'! make: number {IntegerVar} ^self create: number! !Heaper subclass: #Connection instanceVariableNames: '' classVariableNames: 'TheBootPlans {PrimPtr2PtrTable of: Category with: BootPlan} ' poolDictionaries: '' category: 'Xanadu-cobbler'! Connection comment: 'Suclasses represent particular kinds of connections. The connection object serves two purposes: you can get the boot object from it, and you can destroy it to break the connection. Note that destroying the bootObject does not break the connection because you might have gotten other objects from it.'! (Connection getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #EQ; yourself)! !Connection methodsFor: 'accessing'! {Category} bootCategory self subclassResponsibility! {Heaper} bootHeaper self subclassResponsibility! ! !Connection methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Connection class instanceVariableNames: ''! (Connection getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #EQ; yourself)! !Connection class methodsFor: 'smalltalk: init'! initTimeNonInherited TheBootPlans _ PrimPtr2PtrTable make: 8.! linkTimeNonInherited TheBootPlans _ NULL! ! !Connection class methodsFor: 'registration'! {void} clearPlan: cat {Category} "Throw out any plan associated with cat." TheBootPlans remove: cat! {void} registerBootPlan: plan {BootPlan} "For the current run, return plan if anyone looks for a bootPlan that returns an instance of the category that plan returns." TheBootPlans at: plan bootCategory introduce: plan! ! !Connection class methodsFor: 'creation'! make: category {Category} ^((TheBootPlans get: category) cast: BootPlan) connection! !Connection subclass: #DirectConnection instanceVariableNames: ' myCategory {Category} myHeaper {Heaper}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-cobbler'! DirectConnection comment: 'We just made the object, so the connection is just a reference to the object.'! (DirectConnection getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !DirectConnection methodsFor: 'accessing'! {Category} bootCategory ^myCategory! {Heaper} bootHeaper ^myHeaper! ! !DirectConnection methodsFor: 'creation'! create: cat {Category} with: heaper {Heaper} super create. myCategory _ cat. myHeaper _ heaper! {void} destruct "myHeaper destroy. There are bootHeapers that you REALLY don't want to destroy, such as the GrandMap" super destruct! !Connection subclass: #DiskConnection instanceVariableNames: ' myCategory {Category} myHeaper {Heaper}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-cobbler'! DiskConnection comment: 'Keep an object from the disk. For the moment, put the disk connection in a global variable and export a function so that anyone can destroy it....'! (DiskConnection getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !DiskConnection methodsFor: 'accessing'! {Category} bootCategory ^myCategory! {Heaper} bootHeaper ^myHeaper! ! !DiskConnection methodsFor: 'creation'! create: cat {Category} with: heaper {Heaper} super create. myCategory _ cat. myHeaper _ heaper! {void} destruct myHeaper _ NULL. CurrentPacker fluidGet purge. CurrentPacker fluidGet destroy. CurrentPacker fluidSet: (NULL basicCast: DiskManager). super destruct! !Connection subclass: #NestedConnection instanceVariableNames: ' myCategory {Category} myHeaper {Heaper} mySub {Connection}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-cobbler'! NestedConnection comment: 'We just made an object that wraps another object, so the connection needs to wrap the connection by which that other object was obtained.'! (NestedConnection getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !NestedConnection methodsFor: 'accessing'! {Category} bootCategory ^myCategory! {Heaper} bootHeaper ^myHeaper! ! !NestedConnection methodsFor: 'creation'! create: cat {Category} with: heaper {Heaper} with: sub {Connection} super create. myCategory _ cat. myHeaper _ heaper. mySub _ sub! {void} destruct mySub destroy. myHeaper destroy. super destruct! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NestedConnection class instanceVariableNames: ''! (NestedConnection getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !NestedConnection class methodsFor: 'creation'! {Connection} make: cat {Category} with: heaper {Heaper} with: sub {Connection} ^self create: cat with: heaper with: sub! !Heaper subclass: #Cookbook instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-cobbler'! (Cookbook getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #EQ; yourself)! !Cookbook methodsFor: 'accessing'! {Category} bootCategory self subclassResponsibility! {Recipe} fetchRecipe: cat {Category} self subclassResponsibility! {Category} getCategoryFor: no {IntegerVar} self subclassResponsibility! {Recipe} getRecipe: cat {Category} self subclassResponsibility! {char star} id "return a string that uniquely determines the version of the cookbook. It should change whenever classes are added or removed, or when their storage or transmission protocol changes" self subclassResponsibility! {Cookbook} next self subclassResponsibility! {IntegerVar} numberOfCategory: cat {Category} self subclassResponsibility! {PtrArray} recipes self subclassResponsibility! ! !Cookbook methodsFor: 'printing'! {void} printOn: oo {ostream reference} self subclassResponsibility! ! !Cookbook methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Cookbook class instanceVariableNames: ''! (Cookbook getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #EQ; yourself)! !Cookbook class methodsFor: 'declaring'! {Cookbook} declareCookbook: id {char star} with: bootCat {Category} with: cuisine {Recipe} "Create and register a cookbook. The cookbook can be looked up according to etiher its name or bootCategory." | recipes {PtrArray} count {Int32} | "preorder -> recipe." recipes _ WeakPtrArray make: XnExecutor noopExecutor with: Heaper preorderMax + 1. count _ ActualCookbook addCuisine: cuisine to: recipes. ^ActualCookbook create: bootCat with: id with: recipes with: count! {Cookbook} declareCookbook: id {char star} with: bootCat {Category} with: cuisine1 {Recipe} with: cuisine2 {Recipe} "Create and register a cookbook. The cookbook can be looked up according to etiher its name or bootCategory." | recipes {PtrArray} count {Int32} | "preorder -> recipe." recipes _ WeakPtrArray make: XnExecutor noopExecutor with: Heaper preorderMax + 1. count _ ActualCookbook addCuisine: cuisine1 to: recipes. count _ count + (ActualCookbook addCuisine: cuisine2 to: recipes). ^ActualCookbook create: bootCat with: id with: recipes with: count! {Cookbook} declareCookbook: id {char star} with: bootCat {Category} with: cuisine1 {Recipe} with: cuisine2 {Recipe} with: cuisine3 {Recipe} "Create and register a cookbook. The cookbook can be looked up according to etiher its name or bootCategory." | recipes {PtrArray} count {Int32} | "preorder -> recipe." recipes _ WeakPtrArray make: XnExecutor noopExecutor with: Heaper preorderMax + 1. count _ ActualCookbook addCuisine: cuisine1 to: recipes. count _ count + (ActualCookbook addCuisine: cuisine2 to: recipes). count _ count + (ActualCookbook addCuisine: cuisine3 to: recipes). ^ActualCookbook create: bootCat with: id with: recipes with: count! {Cookbook} declareCookbook: id {char star} with: bootCat {Category} with: cuisine1 {Recipe} with: cuisine2 {Recipe} with: cuisine3 {Recipe} with: cuisine4 {Recipe} "Create and register a cookbook. The cookbook can be looked up according to etiher its name or bootCategory." | recipes {PtrArray} count {Int32} | "preorder -> recipe." recipes _ WeakPtrArray make: XnExecutor noopExecutor with: Heaper preorderMax + 1. count _ ActualCookbook addCuisine: cuisine1 to: recipes. count _ count + (ActualCookbook addCuisine: cuisine2 to: recipes). count _ count + (ActualCookbook addCuisine: cuisine3 to: recipes). count _ count + (ActualCookbook addCuisine: cuisine4 to: recipes). ^ActualCookbook create: bootCat with: id with: recipes with: count! ! !Cookbook class methodsFor: 'creation'! {Cookbook} make "Just return the empty cookbook." ^ActualCookbook make.String: 'empty'! {Cookbook} make.Category: bootCat {Category} "Return the cookbook registered for the given bootCategory." ^ActualCookbook make.Category: bootCat! {Cookbook} make.String: id {char star} "Return the cookbook registered for the given string." ^ActualCookbook make.String: id! !Cookbook subclass: #ActualCookbook instanceVariableNames: ' myName {char star} myBootCategory {Category} myNext {Cookbook} myRecipes {PtrArray of: Recipe} myDecoding {PtrArray of: Category} myEncoding {UInt32Array}' classVariableNames: 'TheCookbooks {Cookbook} ' poolDictionaries: '' category: 'Xanadu-cobbler'! ActualCookbook comment: 'We internally map from Category to preorder number for the category and lookup using that preorder number.'! (ActualCookbook getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !ActualCookbook methodsFor: 'accessing'! {Category} bootCategory ^myBootCategory! {Recipe} fetchRecipe: cat {Category} ^(myRecipes fetch: cat preorderNumber) cast: Recipe! {Category} getCategoryFor: no {IntegerVar} | category {Category} | category _ (myDecoding fetch: no DOTasLong) cast: Category. category == NULL ifTrue: [Heaper BLAST: #NotInTable]. ^category! {Recipe} getRecipe: cat {Category} | recipe {Recipe} | recipe _ (myRecipes fetch: cat preorderNumber) cast: Recipe. recipe == NULL ifTrue: [Heaper BLAST: #NotInTable]. ^recipe! {char star} id ^myName! {Cookbook} next ^myNext! {IntegerVar} numberOfCategory: cat {Category} | num {Int32} | num _ myEncoding uIntAt: cat preorderNumber. num >= myRecipes count ifTrue: [Heaper BLAST: #UnencodedCategory]. ^num! {PtrArray} recipes ^myRecipes! ! !ActualCookbook methodsFor: 'creation'! create: cat {Category} with: id {char star} with: recipes {PtrArray of: Recipe} with: count {Int32} | preorderLimit {Int32} code {Int32} | super create. myName _ id. myBootCategory _ cat. preorderLimit _ Heaper preorderMax + 1. "preorder -> recipe." myRecipes _ recipes. "preorder -> code." myEncoding _ UInt32Array make: preorderLimit. "code -> category" myDecoding _ PtrArray nulls: count. code _ Int32Zero. Int32Zero almostTo: preorderLimit do: [:i {Int32} | | recipe {Recipe} | recipe _ (myRecipes fetch: i) cast: Recipe. recipe == NULL ifTrue: [myEncoding at: i storeUInt: preorderLimit] ifFalse: [myEncoding at: i storeUInt: code. myDecoding at: code store: recipe categoryOfDish. code _ code + 1]]. myNext _ TheCookbooks. TheCookbooks _ self! {void} destroy "ActualCookbooks last for the whole run."! ! !ActualCookbook methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << 'an ' << self getCategory name! ! !ActualCookbook methodsFor: 'smalltalk: hooks:'! {void RECEIVE.HOOK} receiveClassList: rcvr {Rcvr} | count {IntegerVar} | count _ rcvr receiveIntegerVar. myRecipes _ MuTable make: HeaperSpace make. Int32Zero almostTo: count do: [:i {Int32} | | clName {String} cl {Category} | clName _ rcvr receiveString. [cl _ Smalltalk at: clName asSymbol ifAbsent: [Cookbook BLAST: 'class name not recognized']] smalltalkOnly. myRecipes at: cl store: cl getRecipe.]! {void SEND.HOOK} sendClassList: xmtr {Xmtr} xmtr sendIntegerVar: myRecipes count. myRecipes stepper forEach: [:rec | xmtr sendString: rec categoryOfDish name]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ActualCookbook class instanceVariableNames: ''! (ActualCookbook getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !ActualCookbook class methodsFor: 'global: utility'! {Int32} addCuisine: cuisine {Recipe} to: recipes {PtrArray} | recipe {Recipe} count {Int32} | count _ Int32Zero. recipe _ cuisine. [recipe ~~ NULL] whileTrue: [recipes at: recipe categoryOfDish preorderNumber store: recipe. count _ count + 1. recipe _ recipe next]. ^count! ! !ActualCookbook class methodsFor: 'creation'! {Cookbook} make.Category: bootCat {Category} | cookbook {Cookbook} | cookbook _ TheCookbooks. [cookbook ~~ NULL] whileTrue: [(cookbook bootCategory isEqual: bootCat) ifTrue: [^cookbook]. cookbook _ cookbook next]. Heaper BLAST: #UnknownCookbook. ^NULL "fodder"! {Cookbook} make.String: id {char star} | cookbook {Cookbook} | cookbook _ TheCookbooks. [cookbook ~~ NULL] whileTrue: [(String strcmp: cookbook id with: id) == Int32Zero ifTrue: [^cookbook]. cookbook _ cookbook next]. Heaper BLAST: #UnknownCookbook. ^NULL "fodder"! ! !ActualCookbook class methodsFor: 'smalltalk: initialization'! {void} cleanupGarbage TheCookbooks _ NULL! initTimeNonInherited Cookbook declareCookbook: 'empty' with: Heaper with: NULL! {void} linkTimeNonInherited TheCookbooks _ NULL! !Heaper subclass: #CoordinateSpace instanceVariableNames: ' myEmptyRegion {XnRegion} myFullRegion {XnRegion} myIdentityDsp {Dsp} myAscending {OrderSpec | NULL} myDescending {OrderSpec | NULL}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Spaces-Basic'! CoordinateSpace comment: 'A coordinate space represents (among other things) the domain space of a table. Corresponding to each coordinate space will be a set of objects of the following kinds: Position -- The elements of the coordinate space. Mapping -- (Add a description.) OrderSpec -- The ways of specifying partial orders of this coordinate space''s Positions. XuRegion -- An XuRegion represents a set of Positions. The domain of a table is an XuRegion. When defining a new coordinate space class, one generally defines new corresponing subclasses of each of the above classes. A kind of any of the above classes knows what coordinate space it is a part of (the "coordinateSpace()" message will yield an appropriate kind of CoordinateSpace). CoordinateSpace objects exist mostly just to represent this commonality. Coordinate spaces are disjoint--it is an error to use any of the generic protocol of any of the above classes if the objects in question are of two different coordinate spaces. For example, "dsp->of (pos)" is not an error iff "dsp->coordinateSpace()->isEqual (pos->coordinateSpace())". Note that this class is not COPY or even PSEUDO_COPY. All of the instance variables for CoordinateSpace are basically cached quantities that require vary little actual state from the derived classes in order to be constructed. This realization allows a knot to be untangled when reading these objects from external storage.'! (CoordinateSpace getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; yourself)! !CoordinateSpace methodsFor: 'accessing'! {UInt32} actualHashForEqual ^Heaper takeOop! {OrderSpec CLIENT INLINE} ascending "Essential. The natural full-ordering of the coordinate space." ^self getAscending! {Mapping CLIENT INLINE} completeMapping: range {XnRegion} "Essential. A Mapping which maps each position in this space to every position in the range region. The region can be from any CoordinateSpace." ^Mapping make.CoordinateSpace: self with.Region: range! {OrderSpec CLIENT INLINE} descending "The mirror image of the partial order returned by 'CoordinateSpace::ascending'." ^self getDescending! {XnRegion CLIENT INLINE} emptyRegion "Essential. An empty region in this coordinate space" ^myEmptyRegion! {(OrderSpec | NULL) INLINE} fetchAscending "The natural full-ordering of the coordinate space." ^myAscending! {(OrderSpec | NULL) INLINE} fetchDescending "The mirror image of the partial order returned by 'CoordinateSpace::fetchAscending'." ^myDescending! {XnRegion CLIENT INLINE} fullRegion "A full region in this coordinate space" ^myFullRegion! {OrderSpec} getAscending "Essential. The natural full-ordering of the coordinate space." | result {OrderSpec | NULL} | result := self fetchAscending. result == NULL ifTrue: [Heaper BLAST: #NoFullOrder]. ^result! {OrderSpec} getDescending "The mirror image of the partial order returned by 'CoordinateSpace::getAscending'." | result {OrderSpec | NULL} | result := self fetchDescending. result == NULL ifTrue: [Heaper BLAST: #NoFullOrder]. ^result! {Dsp INLINE} identityDsp "A Dsp which maps all positions in the coordinate space onto themselves" ^myIdentityDsp! {Mapping CLIENT INLINE} identityMapping "Essential. A Mapping which maps all positions in the coordinate space onto themselves" ^self identityDsp! {BooleanVar} isEqual: other{Heaper} self subclassResponsibility! {BooleanVar} verify: thing {Heaper} "tell whether this is a valid Position/XuRegion/Dsp/OrderSpec for this space" thing cast: (Position | XnRegion | Dsp | OrderSpec) into: [:t | ^self isEqual: t coordinateSpace]. "cast into blasts here." ^false! ! !CoordinateSpace methodsFor: 'smalltalk: defaults'! create: emptyRegion {XnRegion} with: fullRegion {XnRegion} with: identityDsp {Dsp} self create: emptyRegion with: fullRegion with: identityDsp with: NULL with: NULL! create: emptyRegion {XnRegion} with: fullRegion {XnRegion} with: identityDsp {Dsp} with: ascending {OrderSpec default: NULL} self create: emptyRegion with: fullRegion with: identityDsp with: ascending with: NULL! ! !CoordinateSpace methodsFor: 'protected: create followup'! {void} finishCreate: emptyRegion {XnRegion} with: fullRegion {XnRegion} with: identityDsp {Dsp} with: ascending {OrderSpec default: NULL} with: descending {OrderSpec default: NULL} myEmptyRegion := emptyRegion. myFullRegion := fullRegion. myIdentityDsp := identityDsp. myAscending := ascending. (descending == NULL and: [ascending ~~ NULL]) ifTrue: [myDescending := ascending reversed] ifFalse: [myDescending := descending].! ! !CoordinateSpace methodsFor: 'create'! create super create. myEmptyRegion := NULL. myFullRegion := NULL. myIdentityDsp := NULL. myAscending := NULL. myDescending := NULL.! create: emptyRegion {XnRegion} with: fullRegion {XnRegion} with: identityDsp {Dsp} with: ascending {OrderSpec default: NULL} with: descending {OrderSpec default: NULL} super create. myEmptyRegion := emptyRegion. myFullRegion := fullRegion. myIdentityDsp := identityDsp. myAscending := ascending. (descending == NULL and: [ascending ~~ NULL]) ifTrue: [myDescending := ascending reversed] ifFalse: [myDescending := descending].! ! !CoordinateSpace methodsFor: 'smalltalk: passe'! {Mapping} importMapping: data {PrimArray} with: rangeSpace {CoordinateSpace default: NULL} self passe! {OrderSpec} importOrderSpec: data {PrimArray} self passe! {XnRegion} importRegion: data {PrimArray} self passe! {Mapping} mapping: data {PrimArray} self passe! {Mapping} mapping: data {PrimArray} with: rangeSpace {CoordinateSpace default: NULL} self passe! {OrderSpec} orderSpec: data {PrimArray} self passe! {XnRegion} region: data {PrimArray} self passe! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CoordinateSpace class instanceVariableNames: ''! (CoordinateSpace getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; yourself)! !CoordinateSpace class methodsFor: 'smalltalk: system'! info.stProtocol "{OrderSpec CLIENT} ascending {Mapping CLIENT} completeMapping: range {XuRegion} {OrderSpec CLIENT} descending {XuRegion CLIENT} emptyRegion {XuRegion CLIENT} fullRegion {Mapping CLIENT} identityMapping "! !CoordinateSpace subclass: #BasicSpace instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Spaces-Basic'! BasicSpace comment: 'BasicSpace versus CoordinateSpace is not a type distinction in that there is no difference in contract with the client. BasicSpace exists as a convenience to the definer of new CoordinateSpaces. A new subclass of CoordinateSpace should be a subclass of BasicSpace iff there is only one coordinateSpace that corresponds to the new class. I.e., that the instances are not parameterized to yield different coordinate spaces. BasicSpace provides some conveniences (especially in Smalltalk) for defining a single canonical instance at dynamic initialization time, and always using it. As this class is irrelevent to CoordinateSpace clients, but is useful to those defining other kinds of coordinate spaces, it is an exellent example of something that would be classified as a "protected" class--something to be persued if we try to make modules more like classes.'! (BasicSpace getOrMakeCxxClassDescription) attributes: ((Set new) add: #OBSOLETE; add: #SMALLTALK.ONLY; add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !BasicSpace methodsFor: 'testing'! {UInt32} actualHashForEqual "is equal to any basic space on the same category of positions" ^self getCategory hashForEqual + 1! {BooleanVar} isEqual: anObject {Heaper} "is equal to any basic space on the same category of positions" ^anObject getCategory == self getCategory! ! !BasicSpace methodsFor: 'creation'! create: emptyRegion {XnRegion} with: fullRegion {XnRegion} with: identityDsp {Dsp} with: ascending {OrderSpec default: NULL} with: descending {OrderSpec default: NULL} super create: emptyRegion with: fullRegion with: identityDsp with: ascending with: descending.! ! !BasicSpace methodsFor: 'smalltalk: defaults'! create: emptyRegion {XnRegion} with: fullRegion {XnRegion} with: identityDsp {Dsp} self create: emptyRegion with: fullRegion with: identityDsp with: NULL with: NULL! create: emptyRegion {XnRegion} with: fullRegion {XnRegion} with: identityDsp {Dsp} with: ascending {OrderSpec default: NULL} self create: emptyRegion with: fullRegion with: identityDsp with: ascending with: NULL! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BasicSpace class instanceVariableNames: 'theSpace {BasicSpace star} '! (BasicSpace getOrMakeCxxClassDescription) attributes: ((Set new) add: #OBSOLETE; add: #SMALLTALK.ONLY; add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !BasicSpace class methodsFor: 'smalltalk: initialization'! initTimeInherited self REQUIRES: PrimSpec. theSpace _ (self new.AllocType: #PERSISTENT) create.! linkTimeInherited theSpace _ NULL.! suppressInitTimeInherited! suppressLinkTimeInherited! !CoordinateSpace subclass: #CrossSpace instanceVariableNames: 'mySubSpaces {PtrArray of: CoordinateSpace}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Spaces-Cross'! CrossSpace comment: 'Represents the cross of several coordinate spaces. '! (CrossSpace getOrMakeCxxClassDescription) friends: 'friend class BoxAccumulator; friend class BoxStepper; friend class GenericCrossSpace; friend class GenericCrossRegion; friend class BoxProjectionStepper;'; attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; yourself)! !CrossSpace methodsFor: 'accessing'! {PtrArray CLIENT of: CoordinateSpace} axes "Essential. The base spaces that I am a cross of." ^mySubSpaces copy cast: PtrArray! {CoordinateSpace CLIENT} axis: dimension {Int32} "The sub coordinate space on the given axis" ^(mySubSpaces fetch: dimension) cast: CoordinateSpace! {Int32 CLIENT INLINE} axisCount "The number of dimensions in this space" ^mySubSpaces count! ! !CrossSpace methodsFor: 'testing'! {UInt32} actualHashForEqual ^mySubSpaces contentsHash bitXor: #cat.U.CrossSpace hashForEqual! {BooleanVar} isEqual: other {Heaper} other cast: CrossSpace into: [:cross | ^cross secretSubSpaces contentsEqual: mySubSpaces] others: [^false]. ^ false "compiler fodder"! ! !CrossSpace methodsFor: 'making'! {Mapping CLIENT} crossOfMappings: subMappings {(PtrArray of: Mapping | NULL) default: NULL} "Essential. Map each coordinate according to the mapping from its space. NULLs mean 'use the identity mapping'" self subclassResponsibility! {CrossOrderSpec CLIENT} crossOfOrderSpecs: subOrderings {(PtrArray of: OrderSpec | NULL) default: NULL} with: subSpaceOrdering {PrimIntArray default: NULL} "Essential. Make a lexical ordering of all elements in the space, using the given ordering for each sub space. If no sub space ordering is given, then it is in the order they are in the array. subSpaceOrdering lists the lexicographic order in which each dimension should be processed. Every dimension should be listed exactly one, from most significant (at index 0) to least significant. subOrderings are indexed by *dimension*, not by lexicographic order. In order to index by lex order, look up the dimension in subSpaceOrdering, and then look up the resulting dimension number in subOrderings." self subclassResponsibility! {Tuple CLIENT} crossOfPositions: coordinates {PtrArray of: Position} "Essential. Make an individual position" self subclassResponsibility! {CrossRegion CLIENT} crossOfRegions: subRegions {PtrArray of: XnRegion | NULL} "Essential. Make a 'rectangular' region as a cross of all the given regions" self subclassResponsibility! {CrossRegion CLIENT} extrusion: dimension {Int32} with: subRegion {XnRegion} "Return a region whose projection is 'subRegion' along 'dimension', but is full on all other dimensions" self subclassResponsibility! ! !CrossSpace methodsFor: 'smalltalk: passe'! {IntegerVar} count self passe "axisCount"! {Int32} intCount self passe "axisCount"! {CrossMapping} makeCrossMapping: subMappings {PtrArray of: Mapping} self passe! {CrossOrderSpec} makeCrossOrderSpec: subOrderings {PtrArray of: OrderSpec | NULL} with: subSpaceOrdering {Int32Array default: NULL} "Make a lexical ordering of all elements in the space, using the given ordering for each sub space. If no sub space ordering is given, then it is in the order they are in the array" self passe! {CrossRegion} makeCrossRegion: subRegions {PtrArray of: XnRegion | NULL} "Make a 'rectangular' region as a cross of all the given regions" self passe! {Tuple} makeTuple: coordinates {PtrArray of: Position} "Make an individual position" self passe! {CoordinateSpace} subSpace: dimension {Int32} self passe "axis"! {PtrArray of: CoordinateSpace} subSpaces self passe "axes"! ! !CrossSpace methodsFor: 'smalltalk: defaults'! {Mapping CLIENT} crossOfMappings ^self crossOfMappings: NULL! {CrossOrderSpec CLIENT} crossOfOrderSpecs ^self crossOfOrderSpecs: NULL with: NULL! {CrossOrderSpec CLIENT} crossOfOrderSpecs: subOrderings {(PtrArray of: OrderSpec | NULL) default: NULL} ^self crossOfOrderSpecs: subOrderings with: NULL! ! !CrossSpace methodsFor: 'protected: accessing'! {PtrArray INLINE of: CoordinateSpace} secretSubSpaces "The actual array of sub spaces. DO NOT MODIFY" ^mySubSpaces! ! !CrossSpace methodsFor: 'protected: creation'! create super create. mySubSpaces := NULL.! create: subSpaces {PtrArray of: CoordinateSpace} super create. mySubSpaces := subSpaces.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CrossSpace class instanceVariableNames: ''! (CrossSpace getOrMakeCxxClassDescription) friends: 'friend class BoxAccumulator; friend class BoxStepper; friend class GenericCrossSpace; friend class GenericCrossRegion; friend class BoxProjectionStepper;'; attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; yourself)! !CrossSpace class methodsFor: 'creation'! {CrossSpace CLIENT} make: subSpaces {PtrArray of: CoordinateSpace} "Make a cross space with the given list of subspaces" "Should use middlemen. Just hard code special cases for now" ^GenericCrossSpace make: (subSpaces copy cast: PtrArray)! make: zeroSpace {CoordinateSpace} with: oneSpace {CoordinateSpace} "Cross two sub spaces" ^GenericCrossSpace create: ((PrimSpec pointer arrayWithTwo: zeroSpace with: oneSpace) cast: PtrArray)! ! !CrossSpace class methodsFor: 'smalltalk: system'! info.stProtocol "{PtrArray CLIENT of: CoordinateSpace} axes {CoordinateSpace CLIENT} axis: dimension {Int32} {Int32 CLIENT} axisCount {Mapping CLIENT} crossOfMappings {Mapping CLIENT} crossOfMappings: subMappings {(PtrArray of: Mapping | NULL) default: NULL} {CrossOrderSpec CLIENT} crossOfOrderSpecs {CrossOrderSpec CLIENT} crossOfOrderSpecs: subOrderings {(PtrArray of: OrderSpec | NULL) default: NULL} {CrossOrderSpec CLIENT} crossOfOrderSpecs: subOrderings {(PtrArray of: OrderSpec | NULL) default: NULL} with: subSpaceOrdering {Int32Array default: NULL} {Tuple CLIENT} crossOfPositions: coordinates {PtrArray of: Position} {CrossRegion CLIENT} crossOfRegions: subRegions {PtrArray of: XuRegion | NULL} {CrossRegion CLIENT} extrusion: dimension {Int32} with: subRegion {XuRegion} "! !CrossSpace subclass: #GenericCrossSpace instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Spaces-Cross'! GenericCrossSpace comment: 'Default implementation of cross coordinate space. was NOT.A.TYPE but that prevented compilation'! (GenericCrossSpace getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #PSEUDO.COPY; yourself)! !GenericCrossSpace methodsFor: 'making'! {Mapping} crossOfMappings: subMappings {(PtrArray of: Mapping | NULL) default: NULL} subMappings == NULL ifTrue: [^CrossMapping make: self]. Int32Zero almostTo: subMappings count do: [:i {Int32} | | subM {Mapping | NULL} | subM := (subMappings fetch: i) cast: Mapping. (subM ~~ NULL and: [(subM isKindOf: Dsp) not]) ifTrue: [MarkM shouldImplement]]. ^CrossMapping make: self with: subMappings! {CrossOrderSpec} crossOfOrderSpecs: subOrderings {(PtrArray of: OrderSpec | NULL) default: NULL} with: subSpaceOrdering {PrimIntArray default: NULL} ^CrossOrderSpec make: self with: subOrderings with: subSpaceOrdering! {Tuple} crossOfPositions: coordinates {PtrArray of: Position} ^ActualTuple make: coordinates! {CrossRegion} crossOfRegions: subRegions {PtrArray of: XnRegion | NULL} | result {PtrArray of: XnRegion} | result := subRegions copy cast: PtrArray. Int32Zero almostTo: result count do: [ :dimension {Int32} | (result fetch: dimension) == NULL ifTrue: [result at: dimension store: (self axis: dimension) fullRegion] ifFalse: [((result fetch: dimension) cast: XnRegion) isEmpty ifTrue: [^self emptyRegion cast: CrossRegion]]]. ^GenericCrossRegion make: self with: 1 with: result! {CrossRegion} extrusion: dimension {Int32} with: subRegion {XnRegion} | projs {PtrArray of: XnRegion} | subRegion isEmpty ifTrue: [^self emptyRegion cast: CrossRegion]. projs := PtrArray nulls: mySubSpaces count. Int32Zero almostTo: mySubSpaces count do: [ :i {Int32} | i = dimension ifTrue: [projs at: i store: subRegion] ifFalse: [projs at: i store: ((mySubSpaces fetch: i) cast: CoordinateSpace) fullRegion]]. ^GenericCrossRegion make: self with: 1 with: projs! ! !GenericCrossSpace methodsFor: 'private: creation'! create: subSpaces {PtrArray of: CoordinateSpace} super create: subSpaces. self finishCreate: (GenericCrossRegion empty: self) with: (GenericCrossRegion full: self with: subSpaces) with: (GenericCrossDsp identity: self with: subSpaces) with: (CrossOrderSpec fetchAscending: self with: subSpaces) with: (CrossOrderSpec fetchDescending: self with: subSpaces).! ! !GenericCrossSpace methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << '<'. Int32Zero almostTo: mySubSpaces count do: [ :i {Int32} | i > Int32Zero ifTrue: [oo << ' x ']. oo << (mySubSpaces fetch: i)]. oo << '>'! ! !GenericCrossSpace methodsFor: 'hooks:'! {void SEND.HOOK} sendGenericCrossSpaceTo: xmtr {Xmtr} xmtr sendHeaper: mySubSpaces.! ! !GenericCrossSpace methodsFor: 'generated:'! {void} sendSelfTo: xmtr {Xmtr} self sendGenericCrossSpaceTo: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GenericCrossSpace class instanceVariableNames: ''! (GenericCrossSpace getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #PSEUDO.COPY; yourself)! !GenericCrossSpace class methodsFor: 'rcvr pseudoconstructors'! {Heaper} make.Rcvr: rcvr {Rcvr} ^(GenericCrossSpace new.Become: ((rcvr cast: SpecialistRcvr) makeIbid: GenericCrossSpace)) create: (rcvr receiveHeaper cast: PtrArray)! ! !GenericCrossSpace class methodsFor: 'pseudoconstructors'! {CrossSpace} make: subSpaces {PtrArray of: CoordinateSpace} ^GenericCrossSpace create: subSpaces! !CoordinateSpace subclass: #FilterSpace instanceVariableNames: 'myBaseSpace {CoordinateSpace}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Filter'! FilterSpace comment: 'A FilterSpace can be described mathematically as a power space of its baseSpace, i.e. the set of all subsets of the baseSpace. Each position in a FilterSpace is a Region in the baseSpace, and each Filter is a set of Regions taken from the baseSpace. See Filter for more detail.'! (FilterSpace getOrMakeCxxClassDescription) attributes: ((Set new) add: #PSEUDO.COPY; add: #CONCRETE; add: #ON.CLIENT; yourself)! !FilterSpace methodsFor: 'creation'! create: base {CoordinateSpace} super create. self finishCreate: (ClosedFilter make: self) with: (OpenFilter make: self) with: (FilterDsp make: self) with: NULL with: NULL. myBaseSpace := base! ! !FilterSpace methodsFor: 'testing'! {UInt32} actualHashForEqual ^myBaseSpace hashForEqual + 1! {BooleanVar} isEqual: other {Heaper} other cast: FilterSpace into: [:fs | ^fs baseSpace isEqual: myBaseSpace] others: [^false]. ^false "fodder"! ! !FilterSpace methodsFor: 'accessing'! {CoordinateSpace CLIENT INLINE} baseSpace "Essential. The CoordinateSpace of the Regions that are the input to Filters in this FilterSpace." ^myBaseSpace! ! !FilterSpace methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '(' << myBaseSpace << ')'! ! !FilterSpace methodsFor: 'making'! {Filter CLIENT INLINE} allFilter: region {XnRegion} "Essential. A region that matches any region that contains all the Positions in, i.e. is a superset of, the given region." ^Filter supersetFilter: self with: region! {Filter CLIENT INLINE} anyFilter: baseRegion {XnRegion} "Essential. A filter that matches any region that intersects the given region." ^Filter intersectionFilter: self with: baseRegion! {Filter INLINE} intersectionFilter: region {XnRegion} "Essential. A filter that matches any region that intersects the given region." ^Filter intersectionFilter: self with: region! {Filter INLINE} notSubsetFilter: region {XnRegion} "A filter matching any regions that is not a subset of the given region." ^Filter notSubsetFilter: self with: region! {Filter INLINE} notSupersetFilter: region {XnRegion} "A filter that matches any region that is not a superset of the given region." ^Filter notSupersetFilter: self with: region! {Filter INLINE} orFilter: subs {ScruSet of: Filter} "A filter that matches any region that any of the filters in the set would have matched." ^Filter orFilter: self with: subs! {FilterPosition CLIENT INLINE} position: baseRegion {XnRegion} "Essential. Given a Region in the baseSpace, make a Position which corresponds to it, so that filter->hasMember (this->position (baseRegion)) iff filter->match (baseRegion)" ^FilterPosition make: baseRegion! {Filter INLINE} subsetFilter: region {XnRegion} "A filter that matches any region that is a subset of the given region." ^Filter subsetFilter: self with: region! {Filter INLINE} supersetFilter: region {XnRegion} "Essential. A region that matches any region that is a superset of the given region." ^Filter supersetFilter: self with: region! ! !FilterSpace methodsFor: 'hooks:'! {void SEND.HOOK} sendFilterSpaceTo: xmtr {Xmtr} xmtr sendHeaper: myBaseSpace.! ! !FilterSpace methodsFor: 'generated:'! {void} sendSelfTo: xmtr {Xmtr} self sendFilterSpaceTo: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FilterSpace class instanceVariableNames: ''! (FilterSpace getOrMakeCxxClassDescription) attributes: ((Set new) add: #PSEUDO.COPY; add: #CONCRETE; add: #ON.CLIENT; yourself)! !FilterSpace class methodsFor: 'creation'! {FilterSpace CLIENT} make: base {CoordinateSpace} "A FilterSpace on the given base space." ^FilterSpace create: base! ! !FilterSpace class methodsFor: 'smalltalk: system'! info.stProtocol "{Filter CLIENT} andFilter: baseRegion {XnRegion} {Filter CLIENT} anyFilter: baseRegion {XnRegion} {CoordinateSpace CLIENT} baseSpace {FilterPosition CLIENT} position: baseRegion {XnRegion} "! ! !FilterSpace class methodsFor: 'rcvr pseudo constructors'! {Heaper} make.Rcvr: rcvr {Rcvr} ^(FilterSpace new.Become: ((rcvr cast: SpecialistRcvr) makeIbid: FilterSpace)) create: (rcvr receiveHeaper cast: CoordinateSpace)! !CoordinateSpace subclass: #HeaperSpace instanceVariableNames: '' classVariableNames: 'TheHeaperSpace {HeaperSpace} ' poolDictionaries: '' category: 'Xanadu-Spaces-Unordered'! HeaperSpace comment: 'A HeaperSpace is one whose positions represent the identity of individual Heapers. Identity of a Heaper is determined according by its response to "isEqual" and "hashForEqual" (see "The Equality of Decisions" for a bunch of surprising issues regarding Heaper equality). A region is a HeaperSpace is a SetRegion (see SetRegion). As a result of having HeaperSpaces, one can use the identity of Heapers to index into hash tables, and still obey the convention that a table maps from positions in some coordinate space. HeaperSpaces cannot (yet?) be used as the domain space for Xanadu Stamps, and therefore also not as the domain space of an IndexedWaldo. In order to do this, the Heapers in question would have to persist in a way that Xanadu doesn''t provide for. As is typical for an unordered space, the only Dsp for this space is the identity Dsp. No type or pseudo-constructor is exported however--the Dsp is gotten by converting a HeaperSpace to a Dsp. Similarly, no heaper-specific type or pseudo-constructor is exported for my regions. The conversions are sufficient. The resulting regions are guaranteed to be SetRegions.'! (HeaperSpace getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #PSEUDO.COPY; yourself)! !HeaperSpace methodsFor: 'creation'! create super create: HeaperRegion make with: HeaperRegion make complement with: HeaperDsp make with: NULL with: NULL! ! !HeaperSpace methodsFor: 'testing'! {UInt32} actualHashForEqual "is equal to any basic space on the same category of positions" ^self getCategory hashForEqual + 1! {BooleanVar} isEqual: anObject {Heaper} "is equal to any basic space on the same category of positions" ^anObject getCategory == self getCategory! ! !HeaperSpace methodsFor: 'generated:'! {void} sendSelfTo: xmtr {Xmtr}! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HeaperSpace class instanceVariableNames: ''! (HeaperSpace getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #PSEUDO.COPY; yourself)! !HeaperSpace class methodsFor: 'smalltalk: init'! initTimeNonInherited TheHeaperSpace := self create! linkTimeNonInherited TheHeaperSpace := NULL! ! !HeaperSpace class methodsFor: 'pseudo constructors'! {HeaperSpace INLINE} make "Return the one instance of HeaperSpace" ^TheHeaperSpace! ! !HeaperSpace class methodsFor: 'rcvr pseudo constructor'! {Heaper} make.Rcvr: rcvr {Rcvr} (rcvr cast: SpecialistRcvr) registerIbid: TheHeaperSpace. ^TheHeaperSpace! !CoordinateSpace subclass: #IDSpace instanceVariableNames: ' myBackend {Sequence | NULL} mySpaceNumber {IntegerVar} myNewIDCounter {Counter}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Spaces-Unordered'! IDSpace comment: 'A space of IDs, which can generate globally unique IDs. Implementation note: myBackend - the identifier of the Server which generated this space. If NULL, then it was generated by the current Server (unless mySpaceNumber is -1, in which case it is the single global IDSpace shared by all Servers. mySpaceNumber - identifies which space this is. If -1, then it is the global ID space, and myBackend must be NULL.'! (IDSpace getOrMakeCxxClassDescription) friends: 'friend IDSimpleStepper; friend class BeGrandMap; friend class IDTester; friend class ID; friend class IDRegion;'; attributes: ((Set new) add: #PSEUDO.COPY; add: #CONCRETE; add: #ON.CLIENT; yourself)! !IDSpace methodsFor: 'making'! {IDRegion CLIENT} iDsFromServer: identifier {Sequence} "Essential. The Region of IDs in this space which might be genrated by the given Server" RaviNow shouldImplement. ^NULL "fodder"! {ID CLIENT} newID "Essential. A new ID guaranteed to be different from every other newID generated by this IDSpace or any IDSpace isEqual to it, on any Server. (Although of course IDs generated using this->oldID () may conflict if the right numbers happen to have been supplied.)" ^ID make: self fetchIDSpace with: NULL with: myNewIDCounter increment! {IDRegion CLIENT} newIDs: count {IntegerVar} "A region containing a finite number of globally unique IDs. See newID for uniqueness guarantees." ^IDRegion make: self fetchIDSpace with: (IntegerRegion integerExtent: (myNewIDCounter incrementBy: count) with: count) with: NULL with: false! ! !IDSpace methodsFor: 'private: for friends'! {Sequence} backend "Essential. The Server which created this IDSpace" myBackend == NULL ifTrue: [mySpaceNumber = -1 ifTrue: [^Sequence zero] ifFalse: [^FeServer identifier]]. ^myBackend! {Sequence | NULL} fetchBackend ^myBackend! {IDSpace | NULL} fetchIDSpace "NULL if this is the global IDSpace, self otherwise" (myBackend == NULL and: [mySpaceNumber = -1]) ifTrue: [^NULL] ifFalse: [^self]! {IDRegion} oldIDs: backend {Sequence} with: numbers {IntegerRegion} "Recreate a region of IDs from information that was stored outside the Server" backend isZero ifTrue: [(numbers intersects: (IntegerRegion after: IntegerVarZero)) ifTrue: [Heaper BLAST: #InvalidRequest] ifFalse: [^IDRegion make: self fetchIDSpace with: numbers with: NULL with: false]] ifFalse: [ | table {MuTable} | (numbers isSubsetOf: (IntegerRegion after: IntegerVarZero)) ifFalse: [Heaper BLAST: #InvalidRequest]. (backend isEqual: FeServer identifier) ifTrue: [^IDRegion make: self fetchIDSpace with: numbers with: NULL with: false]. table := MuTable make: SequenceSpace make. table at: backend store: numbers. ^IDRegion make: self fetchIDSpace with: IntegerRegion make with: table asImmuTable with: false]. ^NULL "fodder"! {IntegerVar} spaceNumber "Essential. Identifies this particular space among all those generated by the same Server." ^mySpaceNumber! ! !IDSpace methodsFor: 'private: create'! create: backend {Sequence | NULL} with: number {IntegerVar} with: counter {Counter} super create. myBackend := backend. mySpaceNumber := number. self finishCreation. myNewIDCounter := counter! {void} finishCreation | myself {IDSpace} | (myBackend == NULL and: [mySpaceNumber = -1]) ifTrue: [myself := NULL] ifFalse: [myself := self]. self finishCreate: (IDRegion usingx: myself with: (IntegerSpace make emptyRegion cast: IntegerRegion) with: NULL with: false) with: (IDRegion usingx: myself with: (IntegerSpace make fullRegion cast: IntegerRegion) with: NULL with: true) with: (IDDsp make: self) with: (IDUpOrder make: self) with: NULL! ! !IDSpace methodsFor: 'testing'! {UInt32} actualHashForEqual myBackend == NULL ifTrue: [^mySpaceNumber DOThashForEqual bitXor: self getCategory hashForEqual] ifFalse: [^(myBackend hashForEqual bitXor: mySpaceNumber DOThashForEqual) bitXor: self getCategory hashForEqual]! {BooleanVar} isEqual: other {Heaper} other cast: IDSpace into: [ :space | ^self == space or: [mySpaceNumber = space spaceNumber and: [(myBackend == NULL and: [space fetchBackend == NULL]) or: [myBackend ~~ NULL and: [space fetchBackend ~~ NULL and: [myBackend isEqual: space fetchBackend]]]]]] others: [^false]. ^false "fodder"! ! !IDSpace methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '('. self fetchIDSpace == NULL ifTrue: [oo << '!!0'] ifFalse: [oo << self backend << '.' << mySpaceNumber]. oo << ')'! ! !IDSpace methodsFor: 'accessing'! {UInt8Array CLIENT} export "Essential. Produce an array which can be handed to Server::importIDSpace on any Server to get back the same IDSpace" | xmtr {SpecialistXmtr} result {WriteVariableArrayStream} | result := WriteVariableArrayStream make: 200. xmtr := Binary2XcvrMaker make makeXmtr: (TransferSpecialist make: Cookbook make) with: result. ID exportSequence: xmtr with: self backend. xmtr sendIntegerVar: self spaceNumber. ^result array! ! !IDSpace methodsFor: 'obsolete:'! {Sequence} identifier "A Sequence uniquely identifying this IDSpace, so that FeServer::current ()->oldIDSpace (this->identifier ()) ->isEqual (this)" Ravi thingToDo. "get rid of this message and its clients" ^self backend withLast: mySpaceNumber! ! !IDSpace methodsFor: 'hooks:'! {void SEND.HOOK} sendIDSpaceTo: xmtr {Xmtr} xmtr sendHeaper: myBackend. xmtr sendIntegerVar: mySpaceNumber. xmtr sendHeaper: myNewIDCounter.! ! !IDSpace methodsFor: 'smalltalk: passe'! {ID} oldID: identifier {Sequence} "Recreate an ID from its identifier." self passe.! ! !IDSpace methodsFor: 'generated:'! {void} sendSelfTo: xmtr {Xmtr} self sendIDSpaceTo: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! IDSpace class instanceVariableNames: ''! (IDSpace getOrMakeCxxClassDescription) friends: 'friend IDSimpleStepper; friend class BeGrandMap; friend class IDTester; friend class ID; friend class IDRegion;'; attributes: ((Set new) add: #PSEUDO.COPY; add: #CONCRETE; add: #ON.CLIENT; yourself)! !IDSpace class methodsFor: 'creation'! {IDSpace CLIENT} global "Return the global ID space." ^CurrentGrandMap fluidGet globalIDSpace! {IDSpace CLIENT} import: data {PrimIntArray} "Essential. Take some information describing an IDSpace and create the IDSpace it was exported from." | rcvr {SpecialistRcvr} backend {Sequence} number {IntegerVar} | rcvr := Binary2XcvrMaker make makeRcvr: (TransferSpecialist make: Cookbook make) with: (XnReadStream make: (data cast: UInt8Array)). backend := ID importSequence: rcvr. number := rcvr receiveIntegerVar. ^self make: backend with: number! {IDSpace CLIENT} unique "Essential. Create a new globally unique space of IDs" ^CurrentGrandMap fluidGet newIDSpace! ! !IDSpace class methodsFor: 'private: pseudo constructors'! make: identifier {Sequence | NULL} with: number {IntegerVar} ^self make: identifier with: number with: (CurrentGrandMap fluidGet getOrMakeIDCounter: identifier with: number)! make: identifier {Sequence | NULL} with: number {IntegerVar} with: counter {Counter} | cgm {BeGrandMap} | cgm := CurrentGrandMap fluidFetch. (identifier ~~ NULL and: [identifier isZero or: [cgm ~~ NULL and: [identifier isEqual: cgm identifier]]]) ifTrue: [^self create: NULL with: number with: counter]. ^self create: identifier with: number with: counter! ! !IDSpace class methodsFor: 'smalltalk: passe'! {FilterSpace of: IDSpace} iDFilterSpace "The coordinate space of filters on IDRegions." self passe! {Filter of: IDSpace} openIDFilter self passe.! ! !IDSpace class methodsFor: 'rcvr pseudo constructors'! {Heaper} make.Rcvr: rcvr {Rcvr} | memory {Heaper} backend {Sequence} space {IntegerVar} idCounter {Counter} | self thingToDo. "Should intern someday" memory _ (rcvr cast: SpecialistRcvr) makeIbid: IDSpace. backend _ rcvr receiveHeaper cast: Sequence. space _ rcvr receiveIntegerVar. idCounter _ rcvr receiveHeaper cast: Counter. ^(IDSpace new.Become: memory) create: backend with: space with: idCounter! ! !IDSpace class methodsFor: 'smalltalk: system'! info.stProtocol "{UInt8Array CLIENT} export {IDRegion CLIENT} iDsFromServer: identifier {Sequence} {ID CLIENT} newID {IDRegion CLIENT} newIDs: count {IntegerVar} "! !CoordinateSpace subclass: #IntegerSpace instanceVariableNames: '' classVariableNames: 'TheIntegerSpace {IntegerSpace} ' poolDictionaries: '' category: 'Xanadu-Spaces-Integers'! IntegerSpace comment: 'The space of all integers. See the class comments in IntegerRegion, XuInteger, and IntegerDsp for interesting properties of this space. Especially IntegerRegion. IntegerSpaces are the most frequently used of the coordinate spaces. XuArrays are an efficient data structure which we provide as a table whose domain space is an integer space. In so doing, the notion of an array is made to be simply a particular case of a table indexed by the positions of a coordinate space. However, IntegerSpaces and XuArrays are both expected to be more efficient than other spaces and tables built on other spaces. See XuArray'! (IntegerSpace getOrMakeCxxClassDescription) friends: '/* friends for class IntegerSpace */ friend class IntegerRegion; friend class IntegerDsp; '; attributes: ((Set new) add: #PSEUDO.COPY; add: #CONCRETE; add: #ON.CLIENT; yourself)! !IntegerSpace methodsFor: 'creation'! create super create: (IntegerRegion usingx: false with: Int32Zero with: (IntegerVarArray zeros: Int32Zero)) with: (IntegerRegion usingx: true with: Int32Zero with: (IntegerVarArray zeros: Int32Zero)) with: IntegerMapping identity with: IntegerUpOrder make! ! !IntegerSpace methodsFor: 'making'! {IntegerRegion CLIENT} above: start {IntegerPos} with: inclusive {BooleanVar} "Essential. Make a region that contains all integers greater than (or equal if inclusive is true) to start." | after {IntegerVar} | after _ start asIntegerVar. inclusive ifFalse: [after _ after + 1]. ^IntegerRegion after: after! {IntegerRegion CLIENT} below: stop {IntegerPos} with: inclusive {BooleanVar} "Make a region that contains all integers less than (or equal if inclusive is true) to stop." | after {IntegerVar} | after _ stop asIntegerVar. inclusive ifTrue: [after _ after + 1]. ^IntegerRegion before: after! {IntegerRegion CLIENT} interval: start {IntegerPos} with: stop {IntegerPos} "Make a region that contains all integers greater than or equal to start and less than stop." ^IntegerRegion make: start asIntegerVar with: stop asIntegerVar! {IntegerPos CLIENT INLINE} position: value {IntegerVar} "Essential. Make an integer Position object" ^value integer! {IntegerMapping CLIENT} translation: value {IntegerVar} "Essential. Make a Mapping which adds a fixed amount to any value. Should this just be supplanted by CoordinateSpace::mapping ()?" value = IntegerVarZero ifTrue: [^self identityDsp cast: IntegerMapping]. ^IntegerMapping make: value! ! !IntegerSpace methodsFor: 'testing'! {UInt32} actualHashForEqual "is equal to any basic space on the same category of positions" ^self getCategory hashForEqual + 1! {BooleanVar} isEqual: anObject {Heaper} "is equal to any basic space on the same category of positions" ^anObject getCategory == self getCategory! ! !IntegerSpace methodsFor: 'smalltalk: passe'! {IntegerPos} integer: value {IntegerVar} self passe "position"! ! !IntegerSpace methodsFor: 'generated:'! {void} sendSelfTo: xmtr {Xmtr}! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! IntegerSpace class instanceVariableNames: ''! (IntegerSpace getOrMakeCxxClassDescription) friends: '/* friends for class IntegerSpace */ friend class IntegerRegion; friend class IntegerDsp; '; attributes: ((Set new) add: #PSEUDO.COPY; add: #CONCRETE; add: #ON.CLIENT; yourself)! !IntegerSpace class methodsFor: 'creation'! {IntegerSpace INLINE} implicitReceiver "Get the receievr for wire requests." ^TheIntegerSpace! {IntegerSpace CLIENT INLINE} make "return the one integer space" ^TheIntegerSpace! ! !IntegerSpace class methodsFor: 'rcvr pseudo constructor'! {Heaper} make.Rcvr: rcvr {Rcvr} (rcvr cast: SpecialistRcvr) registerIbid: TheIntegerSpace. ^TheIntegerSpace! ! !IntegerSpace class methodsFor: 'smalltalk: init'! initTimeNonInherited TheIntegerSpace := self create! linkTimeNonInherited TheIntegerSpace := NULL! ! !IntegerSpace class methodsFor: 'smalltalk: system'! info.stProtocol "{IntegerRegion CLIENT} above: start {IntegerVar} with: inclusive {BooleanVar} {IntegerRegion CLIENT} below: start {IntegerVar} with: inclusive {BooleanVar} {IntegerRegion CLIENT} interval: start {IntegerVar} with: stop {IntegerVar} {XuInteger CLIENT} position: value {IntegerVar} {IntegerMapping CLIENT} translation: value {IntegerVar} "! !CoordinateSpace subclass: #RealSpace instanceVariableNames: '' classVariableNames: 'TheRealSpace {RealSpace} ' poolDictionaries: '' category: 'Xanadu-tumbler'! RealSpace comment: 'Non-arithmetic space of real numbers in which only certain positions are explicitly representable. In this release, the only exactly representable numbers are those real numbers which can be represented in IEEE64 (double precision) format. Future releases may make more real numbers representable.'! (RealSpace getOrMakeCxxClassDescription) attributes: ((Set new) add: #PSEUDO.COPY; add: #CONCRETE; add: #ON.CLIENT; yourself)! !RealSpace methodsFor: 'create'! create super create: (RealRegion make: false with: PtrArray empty) with: (RealRegion make: true with: PtrArray empty) with: RealDsp make with: RealUpOrder make! ! !RealSpace methodsFor: 'making'! {RealRegion CLIENT} above: val {RealPos} with: inclusive {BooleanVar} "The region consisting of all positions >= val if inclusive, or all > val if not inclusive." inclusive ifTrue: [^RealRegion make: false with: (PrimSpec pointer arrayWith: (BeforeReal make: val))] ifFalse: [^RealRegion make: false with: (PrimSpec pointer arrayWith: (AfterReal make: val))]! {RealRegion CLIENT} below: val {RealPos} with: inclusive {BooleanVar} "The region consisting of all positions <= val if inclusive, or all < val if not inclusive." inclusive ifTrue: [^RealRegion make: true with: (PrimSpec pointer arrayWith: (AfterReal make: val))] ifFalse: [^RealRegion make: true with: (PrimSpec pointer arrayWith: (BeforeReal make: val))]! {RealRegion CLIENT} interval: start {RealPos} with: stop {RealPos} "Return a region of all numbers >= lower and < upper." MarkM thingToDo. "use a single constructor" ^((self above: start with: true) intersect: (self below: stop with: false)) cast: RealRegion! {RealPos CLIENT INLINE} position: val {IEEE64} "The XuReal representing the same real number as that exactly represented by 'val'. If 'val' doesn't represent a real number (i.e., it is an infinity or a NAN), then this message BLASTs. If 'val' is a negative zero, it is silently converted to a positive zero" ^RealPos make: val! ! !RealSpace methodsFor: 'obsolete:'! {RealRegion} after: val {IEEE64} "The region consisting of all position >= val. Should this just be supplanted by CoordinateSpace::region ()?" self thingToDo. "update clients" ^RealRegion make: false with: (PrimSpec pointer arrayWith: (BeforeReal make: (RealPos make: val)))! {RealRegion} before: val {IEEE64} "The region consisting of all position <= val Should this just be supplanted by CoordinateSpace::region ()?" self thingToDo. "update clients" ^RealRegion make: true with: (PrimSpec pointer arrayWith: (AfterReal make: (RealPos make: val)))! {RealRegion} strictlyAfter: val {IEEE64} "The region consisting of all position > val Should this just be supplanted by CoordinateSpace::region ()? Add Boolean to after to say whether its inclusive?" self thingToDo. "update clients" ^RealRegion make: false with: (PrimSpec pointer arrayWith: (AfterReal make: (RealPos make: val)))! {RealRegion} strictlyBefore: val {IEEE64} "The region consisting of all position < val Should this just be supplanted by CoordinateSpace::region ()? Add Boolean to before to say whether its inclusive?" self thingToDo. "update clients" ^RealRegion make: true with: (PrimSpec pointer arrayWith: (AfterReal make: (RealPos make: val)))! ! !RealSpace methodsFor: 'testing'! {UInt32} actualHashForEqual "is equal to any basic space on the same category of positions" ^self getCategory hashForEqual + 1! {BooleanVar} isEqual: anObject {Heaper} "is equal to any basic space on the same category of positions" ^anObject getCategory == self getCategory! ! !RealSpace methodsFor: 'generated:'! {void} sendSelfTo: xmtr {Xmtr}! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RealSpace class instanceVariableNames: ''! (RealSpace getOrMakeCxxClassDescription) attributes: ((Set new) add: #PSEUDO.COPY; add: #CONCRETE; add: #ON.CLIENT; yourself)! !RealSpace class methodsFor: 'creation'! {RealSpace CLIENT INLINE} make ^TheRealSpace! ! !RealSpace class methodsFor: 'rcvr pseudo constructors'! {Heaper} make.Rcvr: rcvr {Rcvr} (rcvr cast: SpecialistRcvr) registerIbid: TheRealSpace. ^TheRealSpace! ! !RealSpace class methodsFor: 'smalltalk: init'! initTimeNonInherited self REQUIRES: PrimSpec. TheRealSpace := self create! linkTimeNonInherited TheRealSpace := NULL! ! !RealSpace class methodsFor: 'smalltalk: system'! info.stProtocol "{RealRegion CLIENT} above: val {IEEE64} with: inclusive {BooleanVar} {RealRegion CLIENT} below: val {IEEE64} with: inclusive {BooleanVar} {RealRegion CLIENT} interval: lower {XuRegion} with: upper {XuReal} {XuReal CLIENT} position: val {IEEE64} "! !CoordinateSpace subclass: #SequenceSpace instanceVariableNames: '' classVariableNames: 'TheSequenceSpace {SequenceSpace} ' poolDictionaries: '' category: 'Xanadu-tumbler'! SequenceSpace comment: 'The space of all Sequences'! (SequenceSpace getOrMakeCxxClassDescription) friends: '/* friends for class SequenceSpace */ friend class Sequence; '; attributes: ((Set new) add: #PSEUDO.COPY; add: #CONCRETE; add: #ON.CLIENT; yourself)! !SequenceSpace methodsFor: 'create'! create super create: (SequenceRegion usingx: false with: PtrArray empty) with: (SequenceRegion usingx: true with: PtrArray empty) with: (SequenceMapping make: IntegerVarZero with: Sequence zero) with: SequenceUpOrder make! ! !SequenceSpace methodsFor: 'temporary'! {Sequence CLIENT login INLINE} position: numbers {PrimArray} ^self position: numbers with: IntegerVarZero! ! !SequenceSpace methodsFor: 'making'! {SequenceRegion CLIENT} above: sequence {Sequence} with: inclusive {BooleanVar} "Essential. All sequences >= sequence if inclusive, > sequence if not." inclusive ifTrue: [^SequenceRegion usingx: false with: ((PrimSpec pointer arrayWith: (BeforeSequence make: sequence)) cast: PtrArray)] ifFalse: [^SequenceRegion usingx: false with: ((PrimSpec pointer arrayWith: (AfterSequence make: sequence)) cast: PtrArray)]! {SequenceRegion CLIENT} below: sequence {Sequence} with: inclusive {BooleanVar} "Essential. All sequences <= sequence if inclusive, < sequence if not." inclusive ifTrue: [^SequenceRegion usingx: true with: ((PrimSpec pointer arrayWith: (AfterSequence make: sequence)) cast: PtrArray)] ifFalse: [^SequenceRegion usingx: true with: ((PrimSpec pointer arrayWith: (BeforeSequence make: sequence)) cast: PtrArray)]! {SequenceRegion CLIENT} interval: start {Sequence} with: stop {Sequence} "Return a region of all sequence >= lower and < upper." "Ravi thingToDo." "use a single constructor" "Performance" ^((self above: start with: true) intersect: (self below: stop with: false)) cast: SequenceRegion! {SequenceMapping CLIENT} mapping: shift {IntegerVar} with: translation {Sequence default: NULL} "A transformation which shifts a value by some number of places and then adds a translation to it." self thingToDo. "better name for this method" translation == NULL ifTrue: [^SequenceMapping make: shift with: Sequence zero]. ^SequenceMapping make: shift with: translation! {Sequence CLIENT login} position: arg {PrimArray} with: shift {IntegerVar} "Essential. A sequence using the given numbers and shift. Leading and trailing zeros will be stripped, and a copy will be made so that noone modifies it" "IntegerVars cannot have default arguments" | numbers {PrimIntegerArray} | numbers _ arg cast: PrimIntegerArray. numbers == NULL ifTrue: [^Sequence usingx: shift with: (IntegerVarArray zeros: Int32Zero)]. ^Sequence usingx: shift with: (numbers copy cast: PrimIntegerArray)! {SequenceRegion CLIENT} prefixedBy: sequence {Sequence} with: limit {IntegerVar} "Essential. All sequences which match the given one up to and including the given index." ^SequenceRegion usingx: false with: ((PrimSpec pointer arrayWithTwo: (BeforeSequencePrefix below: sequence with: limit) with: (BeforeSequencePrefix above: sequence with: limit)) cast: PtrArray)! ! !SequenceSpace methodsFor: 'smalltalk: passe'! {Sequence} sequence: numbers {PrimIntegerArray | NULL} with: shift {IntegerVar | IntegerVarZero} self passe "position"! {SequenceRegion} sequencesAfter: sequence {Sequence} "Essential. All sequences greater than or equal to the given sequence. Should this just be supplanted by CoordinateSpace::region ()?" self passe. ^SequenceRegion usingx: false with: (PrimSpec pointer arrayWith: (BeforeSequence make: sequence))! {SequenceRegion} sequencesBefore: sequence {Sequence} "Essential. All sequences less than or equal to the given sequence. Should this just be supplanted by CoordinateSpace::region ()?" self passe. ^SequenceRegion usingx: true with: (PrimSpec pointer arrayWith: (AfterSequence make: sequence))! {SequenceRegion} sequencesPrefixedBy: sequence {Sequence} with: limit {IntegerVar} "Essential. All sequences which match the given one up to and including the given index. Should this just be supplanted by CoordinateSpace::region ()?" self passe. ^SequenceRegion usingx: false with: (PrimSpec pointer arrayWithTwo: (BeforeSequencePrefix below: sequence with: limit) with: (BeforeSequencePrefix above: sequence with: limit))! {SequenceMapping} shiftAndTranslation self passe! {SequenceDsp} shiftAndTranslation: shift {IntegerVar} self passe! {SequenceDsp} shiftAndTranslation: shift {IntegerVar} with: translation {Sequence} self passe! ! !SequenceSpace methodsFor: 'testing'! {UInt32} actualHashForEqual "is equal to any basic space on the same category of positions" ^self getCategory hashForEqual + 1! {BooleanVar} isEqual: anObject {Heaper} "is equal to any basic space on the same category of positions" ^anObject getCategory == self getCategory! ! !SequenceSpace methodsFor: 'smalltalk: defaults'! {SequenceMapping CLIENT} mapping: shift {IntegerVar} "A transformation which shifts a value by some number of places and then adds a translation to it." ^self mapping: shift with: NULL! ! !SequenceSpace methodsFor: 'generated:'! {void} sendSelfTo: xmtr {Xmtr}! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! SequenceSpace class instanceVariableNames: ''! (SequenceSpace getOrMakeCxxClassDescription) friends: '/* friends for class SequenceSpace */ friend class Sequence; '; attributes: ((Set new) add: #PSEUDO.COPY; add: #CONCRETE; add: #ON.CLIENT; yourself)! !SequenceSpace class methodsFor: 'rcvr creation'! {Heaper} make.Rcvr: rcvr {Rcvr} (rcvr cast: SpecialistRcvr) registerIbid: TheSequenceSpace. ^TheSequenceSpace! ! !SequenceSpace class methodsFor: 'creation'! {SequenceSpace INLINE} implicitReceiver "Get the receiver for wire requests." ^TheSequenceSpace! {SequenceSpace CLIENT login INLINE} make ^TheSequenceSpace! ! !SequenceSpace class methodsFor: 'smalltalk: init'! initTimeNonInherited self REQUIRES: Sequence. TheSequenceSpace := self create! linkTimeNonInherited TheSequenceSpace := NULL! ! !SequenceSpace class methodsFor: 'smalltalk: system'! info.stProtocol "{SequenceRegion CLIENT} above: sequence {Sequence} with: inclusive {BooleanVar} {SequenceRegion CLIENT} below: sequence {Sequence} with: inclusive {BooleanVar} {SequenceRegion CLIENT} interval: lower {Region} with: upper {Sequence} {SequenceMapping CLIENT} mapping: shift {IntegerVar} with: translation {Sequence} {Sequence CLIENT} position: numbers {PrimIntegerArray} {Sequence CLIENT} position: numbers {PrimIntegerArray | NULL} with: shift {IntegerVar | IntegerVarZero} {SequenceRegion CLIENT} prefixedBy: sequence {Sequence} with: limit {IntegerVar} "! !XnExecutor subclass: #DeleteExecutor instanceVariableNames: '' classVariableNames: ' StorageArray {void vector star} StorageHolders {WeakPtrArray} ' poolDictionaries: '' category: 'Xanadu-gchooks'! DeleteExecutor comment: 'This executor manages objects that need to release non-Heaper storage on finalization.'! (DeleteExecutor getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; add: #NOT.A.TYPE; yourself)! !DeleteExecutor methodsFor: 'invoking'! {void} execute: estateIndex {Int32} | storage {void star} | storage := StorageArray at: estateIndex. storage ~~ NULL ifTrue: [ storage delete]. StorageArray at: estateIndex put: NULL.! ! !DeleteExecutor methodsFor: 'protected: create'! create super create! ! !DeleteExecutor methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DeleteExecutor class instanceVariableNames: ''! (DeleteExecutor getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; add: #NOT.A.TYPE; yourself)! !DeleteExecutor class methodsFor: 'accessing'! {void} registerHolder: holder {Heaper} with: storage {void star} | slot {Int32} | StorageArray == NULL ifTrue: [ | exec {XnExecutor} | 'DeleteExecutor::StorageArray = new void* [32]; memset (DeleteExecutor::StorageArray, 0, 32 * sizeof(void*));' translateOnly. [StorageArray := PtrArray nulls: 32] smalltalkOnly. exec := DeleteExecutor create. StorageHolders := WeakPtrArray make: exec with: 32]. slot := StorageHolders indexOf: NULL. slot == -1 ifTrue: [ slot := StorageHolders count. 'void ** newArray = new void* [slot + 16]; memset(&newArray[slot], 0, 16 * sizeof(void*)); MEMMOVE(newArray, DeleteExecutor::StorageArray, (int)slot); delete DeleteExecutor::StorageArray; DeleteExecutor::StorageArray = newArray;' translateOnly. [StorageArray := StorageArray copyGrow: 16] smalltalkOnly. StorageHolders := (StorageHolders copyGrow: 16) cast: WeakPtrArray]. StorageArray at: slot put: storage. StorageHolders at: slot store: holder.! {void} unregisterHolder: holder {Heaper} with: storage {void star} | slot {Int32} | slot := StorageHolders indexOfEQ: holder. [slot ~= -1 and: [slot < StorageHolders count and: [(StorageArray at: slot) ~~ storage]]] whileTrue: [ slot := StorageHolders indexOfEQ: holder with: slot + 1]. (slot == -1 or: [(StorageArray at: slot) ~~ storage]) ifTrue: [ Heaper BLAST: #SanityViolation]. StorageArray at: slot put: NULL. StorageHolders at: slot store: NULL.! ! !DeleteExecutor class methodsFor: 'smalltalk: init'! linkTimeNonInherited StorageArray := NULL. StorageHolders := NULL.! !Heaper subclass: #DetectorEvent instanceVariableNames: ' myNext {DetectorEvent} myDetector {IntegerVar}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! DetectorEvent comment: 'The detectors for comm create these and queue them up because they can only go out between requests.'! (DetectorEvent getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !DetectorEvent methodsFor: 'accessing'! {IntegerVar} detector ^myDetector! {DetectorEvent} next ^myNext! {void} setNext: event {DetectorEvent} myNext _ event! ! !DetectorEvent methodsFor: 'triggering'! {void} trigger: pm {PromiseManager} "Send the message across the wire." self subclassResponsibility! ! !DetectorEvent methodsFor: 'creation'! create: detector {IntegerVar} super create. myDetector _ detector. myNext _ NULL! ! !DetectorEvent methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! !DetectorEvent subclass: #DoneEvent instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! (DoneEvent getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !DoneEvent methodsFor: 'triggering'! {void} trigger: pm {PromiseManager} "Send the message across the wire." pm sendResponse: PromiseManager doneResponse. pm sendIntegerVar: self detector.! ! !DoneEvent methodsFor: 'creation'! create: detector {IntegerVar} super create: detector! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DoneEvent class instanceVariableNames: ''! (DoneEvent getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !DoneEvent class methodsFor: 'creation'! {DetectorEvent} make: detector {IntegerVar} ^ self create: detector! !DetectorEvent subclass: #FilledEvent instanceVariableNames: 'myFilling {Heaper}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! (FilledEvent getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !FilledEvent methodsFor: 'triggering'! {void} trigger: pm {PromiseManager} "Send the message across the wire." pm sendResponse: PromiseManager filledResponse. pm sendIntegerVar: self detector. pm sendPromise: myFilling! ! !FilledEvent methodsFor: 'creation'! create: detector {IntegerVar} with: filling {Heaper} super create: detector. myFilling _ filling! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FilledEvent class instanceVariableNames: ''! (FilledEvent getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !FilledEvent class methodsFor: 'creation'! {DetectorEvent} make: detector {IntegerVar} with: filling {Heaper} ^ self create: detector with: filling! !DetectorEvent subclass: #GrabbedEvent instanceVariableNames: ' myWork {Heaper} myAuthor {Heaper} myReason {IntegerVar}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! (GrabbedEvent getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !GrabbedEvent methodsFor: 'triggering'! {void} trigger: pm {PromiseManager} "Send the message across the wire." pm sendResponse: PromiseManager grabbedResponse. pm sendIntegerVar: self detector. pm sendPromise: myWork. pm sendPromise: myAuthor. pm sendIntegerVar: myReason. pm sendPromise: (PrimIntValue make: myReason)! ! !GrabbedEvent methodsFor: 'creation'! create: detector {IntegerVar} with: work {Heaper} with: author {Heaper} with: reason {IntegerVar} super create: detector. myWork _ work. myAuthor _ author. myReason _ reason! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GrabbedEvent class instanceVariableNames: ''! (GrabbedEvent getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !GrabbedEvent class methodsFor: 'creation'! {DetectorEvent} make: detector {IntegerVar} with: work {Heaper} with: author {Heaper} with: reason {IntegerVar} ^self create: detector with: work with: author with: reason! !DetectorEvent subclass: #RangeFilledEvent instanceVariableNames: 'myFilling {Heaper}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! (RangeFilledEvent getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !RangeFilledEvent methodsFor: 'creation'! create: detector {IntegerVar} with: filling {Heaper} super create: detector. myFilling _ filling! ! !RangeFilledEvent methodsFor: 'triggering'! {void} trigger: pm {PromiseManager} "Send the message across the wire." pm sendResponse: PromiseManager rangeFilledResponse. pm sendIntegerVar: self detector. pm sendPromise: myFilling! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RangeFilledEvent class instanceVariableNames: ''! (RangeFilledEvent getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !RangeFilledEvent class methodsFor: 'creation'! {DetectorEvent} make: detector {IntegerVar} with: filling {Heaper} ^ self create: detector with: filling! !DetectorEvent subclass: #ReleasedEvent instanceVariableNames: ' myWork {Heaper} myReason {IntegerVar}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! (ReleasedEvent getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !ReleasedEvent methodsFor: 'creation'! create: detector {IntegerVar} with: work {Heaper} with: reason {IntegerVar} super create: detector. myWork _ work. myReason _ reason! ! !ReleasedEvent methodsFor: 'triggering'! {void} trigger: pm {PromiseManager} "Send the message across the wire." pm sendResponse: PromiseManager releasedResponse. pm sendIntegerVar: self detector. pm sendPromise: myWork. pm sendIntegerVar: myReason. pm sendPromise: (PrimIntValue make: myReason)! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ReleasedEvent class instanceVariableNames: ''! (ReleasedEvent getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !ReleasedEvent class methodsFor: 'creation'! {DetectorEvent} make: detector {IntegerVar} with: work {Heaper} with: reason {IntegerVar} ^self create: detector with: work with: reason! !DetectorEvent subclass: #RevisedEvent instanceVariableNames: ' myWork {Heaper} myContents {Heaper} myAuthor {Heaper} myTime {IntegerVar} mySequence {IntegerVar}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! (RevisedEvent getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !RevisedEvent methodsFor: 'creation'! create: detector {IntegerVar} with: work {Heaper} with: contents {Heaper} with: author {Heaper} with: time {IntegerVar} with: sequence {IntegerVar} super create: detector. myWork _ work. myContents _ contents. myAuthor _ author. myTime _ time. mySequence _ sequence! ! !RevisedEvent methodsFor: 'triggering'! {void} trigger: pm {PromiseManager} "Send the message across the wire." pm sendResponse: PromiseManager revisedResponse. pm sendIntegerVar: self detector. pm sendPromise: myWork. pm sendPromise: myContents. pm sendPromise: myAuthor. pm sendIntegerVar: myTime. pm sendPromise: (PrimIntValue make: myTime). pm sendIntegerVar: mySequence. pm sendPromise: (PrimIntValue make: mySequence)! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RevisedEvent class instanceVariableNames: ''! (RevisedEvent getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !RevisedEvent class methodsFor: 'creation'! {DetectorEvent} make: detector {IntegerVar} with: work {Heaper} with: contents {Heaper} with: author {Heaper} with: time {IntegerVar} with: sequence {IntegerVar} ^ self create: detector with: work with: contents with: author with: time with: sequence! !Heaper subclass: #DiskManager instanceVariableNames: ' myFluidSpace {char star} myFlockInfoTable {PrimPtrTable} myFlockTable {WeakPtrArray}' classVariableNames: 'SecretEmulsion {Emulsion star} ' poolDictionaries: '' category: 'Xanadu-Snarf'! DiskManager comment: 'This is the public interface for managing objects that should go to disk. This is also the anchor for the so-called Backend emulsion, but I''ll call it the DiskManager emulsion for simplicity.'! (DiskManager getOrMakeCxxClassDescription) friends: '/* friends for class DiskManager */ friend class Abraham; '; attributes: ((Set new) add: #DEFERRED; yourself)! !DiskManager methodsFor: 'shepherds'! {void} destroyFlock: info {FlockInfo} "Queue destroy of the given flock. The destroy will probably happen later." self subclassResponsibility! {void} diskUpdate: info {FlockInfo | NULL} "The flock described by info is Dirty!! On the next commit, rewrite it to the disk." self subclassResponsibility! {void} dismantleFlock: info {FlockInfo} "The flock designated by info has completed all dismantling actions; throw it off the disk." self subclassResponsibility! {void} dropFlock: token {Int32} "The flock identified by token is being removed from memory. For now, this is an error if the flock has been updated. If the flock has been forgotten, then it will be dismantled when next it comes in from disk." self subclassResponsibility! {void} forgetFlock: info {FlockInfo} "Remember that there are no more persistent pointers to the shepherd described by info. If it gets garbage collected, remember to dismantle it when it comes back in from the disk." self subclassResponsibility! {Turtle} getInitialFlock "Return the starting object for the entire backend. This will be the 0th flock in the first snarf following the snarfInfo tables. This will eventually always be a shepherd that describes the protocol of the rest of the disk." self subclassResponsibility! {UInt32} nextHashForEqual "Shepherds use a sequence number for their hash. The most trivial (reasonable) implementation just uses a BatchCounter. This will not be persistent till we get Turtles." self subclassResponsibility! {void} rememberFlock: info {FlockInfo} "There are now persistent pointers to the shepherd described by info. See forgetFlock." self subclassResponsibility! {void} setHashCounter: aCounter {Counter unused}! {void} storeAlmostNewShepherd: shep {Abraham} "Shep has been created, but is not consistent yet. storeNewFlock must be called on it before the next makeConsistent." self subclassResponsibility! {void} storeInitialFlock: turtle {Abraham} with: protocol {XcvrMaker} with: cookbook {Cookbook} "A turtle just got created!! Remember it as the initial flock." self subclassResponsibility! {void} storeNewFlock: shep {Abraham} "Shep just got created!! On some later commit, assign it to a snarf and write it to the disk." self subclassResponsibility! ! !DiskManager methodsFor: 'stubs'! {Abraham} fetchCanonical: hash {UInt32} with: snarfID {SnarfID} with: index {Int32} "If something is already imaged at that location, then return it. If there is already an existing stub with the same hash at a different location, follow them both till we know that they are actually different objects." self subclassResponsibility! {void} makeReal: info {FlockInfo} "Retrieve from the disk the flock at index within the specified snarf. Since stubs are canonical, and this only gets called by stubs, the existing stub will *become* the shepherd for the flock." self subclassResponsibility! {void} registerStub: shep {Abraham} with: snarfID {SnarfID} with: index {Int32} "Called to register a newly created stub (by the diskSpecialist) in the internal tables. The diskSpecialist in particular calls this when it couldn't find an already existing stub (with fetchCacnonical) representing the flock at the particular location." self subclassResponsibility! ! !DiskManager methodsFor: 'transactions'! {void} beginConsistent: dirty {IntegerVar} "This is called before entering consistent block. 'dirty' is the block's declaration of the maximum number of shepherds which it can dirty. If this is a top level consistent block, the virtual image in memory is now in a consistent state. It may be written to the disk if necessary. " self subclassResponsibility! {void} consistentBlockAt: fileName {char star unused} with: lineNo {Int32 unused} "This is called after beginConsistent, but before entering a consistent block, for debugging purposes. Default is to do nothing"! {void} endConsistent: dirty {IntegerVar} "This is called after exiting a consistent block." self subclassResponsibility! {BooleanVar} insideCommit self subclassResponsibility! {void} purge "Flush everything out to disk and remove all purgeable imaged objects from memory. " self subclassResponsibility! {void} purgeClean: noneLocked {BooleanVar default: false} "purge all shepherds that are currently clean, not locked, not dirty, and purgeable. Purging just turns them into stubs, freeing the rest of their flocks. Garbage collection can clean up the flocks and any stubs no longer pointed to by something in memory." self subclassResponsibility! ! !DiskManager methodsFor: 'smalltalk: passe'! {void} consistent: aBlock {BlockClosure} "Execute the block inside a pseudo-transaction." self passe! {void} consistent: dirty {IntegerVar} with: aBlock {BlockClosure} "Execute the block inside a pseudo-transaction." self passe! {void} makeConsistent "The virtual image in memory is now in a consistent state. It may be written to the disk if necessary." self passe! {void} makeConsistentBegin: dirty {IntegerVar} "The virtual image in memory is now in a consistent state. It may be written to the disk if necessary. This is called before entering a top level consistent block. 'dirty' is the block's declaration of the maximum number of shepherds which it can dirty." self passe! {void} makeConsistentEnd "This is called after exiting a top level consistent block." self passe! ! !DiskManager methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! {BooleanVar} isFake self subclassResponsibility! ! !DiskManager methodsFor: 'protected: accessing'! {void INLINE} flockInfoTable: table{PrimPtrTable} myFlockInfoTable := table! {void INLINE} flockTable: table {WeakPtrArray} myFlockTable := table.! ! !DiskManager methodsFor: 'accessing'! {PrimPtrTable INLINE} flockInfoTable ^ myFlockInfoTable! {WeakPtrArray INLINE} flockTable ^ myFlockTable! ! !DiskManager methodsFor: 'protected: creation'! create super create. myFluidSpace _ NULL. myFlockInfoTable _ PrimPtrTable make: 2048. myFlockTable _ WeakPtrArray make: (Cattleman make: self) with: 2048.! {void} destruct (myFluidSpace ~~ NULL) ifTrue: [ CurrentPacker fluidBind: self during: [DiskManager emulsion destructAll]]. super destruct.! ! !DiskManager methodsFor: 'emulsion accessing'! {char star} fluidSpace ^myFluidSpace.! {char star} fluidSpace: aFluidSpace {char star} ^myFluidSpace _ aFluidSpace.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DiskManager class instanceVariableNames: ''! (DiskManager getOrMakeCxxClassDescription) friends: '/* friends for class DiskManager */ friend class Abraham; '; attributes: ((Set new) add: #DEFERRED; yourself)! !DiskManager class methodsFor: 'creation'! {DiskManager} initializeDisk: fname {char star} "This builds the disk managing structure." CurrentPacker fluidSet: (SnarfPacker initializeUrdiOnDisk: fname). ^CurrentPacker fluidGet! make: fname {char star} CurrentPacker fluidSet: (SnarfPacker make: fname). ^CurrentPacker fluidGet! ! !DiskManager class methodsFor: 'emulsion accessing'! {Emulsion} emulsion [SecretEmulsion == nil ifTrue: [SecretEmulsion _ NULL]] smalltalkOnly. (SecretEmulsion == NULL) ifTrue: [ SecretEmulsion _ DiskManagerEmulsion make]. ^SecretEmulsion.! ! !DiskManager class methodsFor: 'smalltalk: initialization'! {void} cleanupGarbage DiskCuisine _ NULL. SecretEmulsion _ NULL.! {void} exitTimeNonInherited CurrentPacker fluidFetch ~~ NULL ifTrue: [CurrentPacker fluidGet destroy. CurrentPacker fluidSet: NULL]! linkTimeNonInherited Recipe star defineGlobal: #DiskCuisine with: NULL. SecretEmulsion _ NULL.! staticTimeNonInherited DiskManager defineFluid: #CurrentPacker with: Emulsion globalEmulsion with: [NULL]. BooleanVar defineFluid: #InsideAgenda with: DiskManager emulsion with: [false].! ! !DiskManager class methodsFor: 'exceptions: exceptions'! bomb.ConsistentBlock: CHARGE {IntegerVar} ^[CurrentPacker fluidGet endConsistent: CHARGE]! ! !DiskManager class methodsFor: 'smalltalk: transactions'! {void} consistent: aBlock {BlockClosure} "Execute the block inside a pseudo-transaction." DiskManager consistent: -1 with: aBlock with: thisContext sender! {void} consistent: dirty {IntegerVar} with: aBlock {BlockClosure} "Execute the block inside a pseudo-transaction." self knownBug. "there are still unbounded consistent bugs which need to be broken up" self consistent: dirty with: aBlock with: thisContext sender! {void} consistent: dirty {IntegerVar default: -1} with: aBlock {BlockClosure} with: context {Context} | fileName {String} | CurrentPacker fluidGet beginConsistent: dirty. "(context isKindOf: MethodContext) ifTrue: [fileName _ context printString] ifFalse: [fileName _ '[] in ', context mclass name, '>>', context selector]. CurrentPacker fluidGet consistentBlockAt: fileName with: context pc." [InsideTransactionFlag fluidBind: true during: aBlock] valueNowOrOnUnwindDo: (DiskManager bomb.ConsistentBlock: dirty)! {void} insistent: aBlock {BlockClosure} "Execute the block inside a pseudo-transaction." DiskManager insistent: -1 with: aBlock with: thisContext sender! {void} insistent: dirty {IntegerVar} with: aBlock {BlockClosure} "Execute the block inside a pseudo-transaction." self insistent: dirty with: aBlock with: thisContext sender! {void} insistent: dirty {IntegerVar default: -1} with: aBlock {BlockClosure} with: context {Context} InsideTransactionFlag fluidFetch assert: 'Must be inside a transaction'. DiskManager consistent: dirty with: aBlock with: context! !DiskManager subclass: #CBlockTrackingPacker instanceVariableNames: ' myPacker {DiskManager} myTracker {CBlockTracker | NULL}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Snarf'! (CBlockTrackingPacker getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !CBlockTrackingPacker methodsFor: 'transactions'! {void} beginConsistent: dirty {IntegerVar} myTracker _ CBlockTracker make: dirty with: myTracker. myPacker beginConsistent: dirty! {void} consistentBlockAt: fileName {char star} with: lineNo {Int32} self checkTracker ifTrue: [myTracker track: fileName with: lineNo. myPacker consistentBlockAt: fileName with: lineNo]! {void} endConsistent: dirty {IntegerVar} self checkTracker ifTrue: [myTracker _ myTracker fetchUnwrapped. myPacker endConsistent: dirty]! {BooleanVar} insideCommit ^ myPacker insideCommit! {void} purge myPacker purge! {void} purgeClean: noneLocked {BooleanVar default: false} myPacker purgeClean: noneLocked! ! !CBlockTrackingPacker methodsFor: 'shepherds'! {void} destroyFlock: info {FlockInfo} "Queue destroy of the given flock. The destroy will probably happen later." myPacker destroyFlock: info! {void} diskUpdate: info {FlockInfo | NULL} self checkTracker ifTrue: [myTracker dirty: info. myPacker diskUpdate: info]! {void} dismantleFlock: info {FlockInfo} "The flock designated by info has completed all dismantling actions; throw it off the disk." myPacker dismantleFlock: info! {void} dropFlock: token {Int32} myPacker dropFlock: token! {void} forgetFlock: info {FlockInfo} self checkTracker ifTrue: [myTracker dirty: info. myPacker forgetFlock: info]! {Turtle} getInitialFlock ^myPacker getInitialFlock! {UInt32} nextHashForEqual ^myPacker nextHashForEqual! {void} rememberFlock: info {FlockInfo} self checkTracker ifTrue: [myTracker dirty: info. myPacker rememberFlock: info]! {void} storeAlmostNewShepherd: shep {Abraham} myPacker storeAlmostNewShepherd: shep! {void} storeInitialFlock: turtle {Abraham} with: protocol {XcvrMaker} with: cookbook {Cookbook} myPacker storeInitialFlock: turtle with: protocol with: cookbook! {void} storeNewFlock: shep {Abraham} self checkTracker ifTrue: [myPacker storeNewFlock: shep. myTracker dirty: shep getInfo]! ! !CBlockTrackingPacker methodsFor: 'stubs'! {Abraham} fetchCanonical: hash {UInt32} with: snarfID {SnarfID} with: index {Int32} ^myPacker fetchCanonical: hash with: snarfID with: index! {void} makeReal: info {FlockInfo} myPacker makeReal: info! {void} registerStub: shep {Abraham} with: snarfID {SnarfID} with: index {Int32} myPacker registerStub: shep with: snarfID with: index! ! !CBlockTrackingPacker methodsFor: 'smalltalk: testing'! consistentCount ^myPacker consistentCount! ! !CBlockTrackingPacker methodsFor: 'create'! create: subPacker {DiskManager} super create. myPacker _ subPacker. myTracker _ NULL. self flockTable: myPacker flockTable. self flockInfoTable: myPacker flockInfoTable.! ! !CBlockTrackingPacker methodsFor: 'protected: destruction'! {void} destruct (myTracker == NULL) assert. myPacker destroy. super destruct! ! !CBlockTrackingPacker methodsFor: 'testing'! {BooleanVar} isFake ^ myPacker isFake! ! !CBlockTrackingPacker methodsFor: 'private:'! {BooleanVar} checkTracker myTracker ~~ NULL ifTrue: [^true]. [Logger] USES. ErrorLog << 'Must be inside consistent block '! {void} commitState: flag {BooleanVar} "Used by ResetCommit bomb" (myPacker cast: SnarfPacker) commitState: flag! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CBlockTrackingPacker class instanceVariableNames: ''! (CBlockTrackingPacker getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !CBlockTrackingPacker class methodsFor: 'creation'! {DiskManager} make: subPacker {DiskManager} ^CBlockTrackingPacker create: subPacker! !DiskManager subclass: #FakePacker instanceVariableNames: ' myTurtle {Turtle | NULL} myCount {UInt4}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Snarf'! FakePacker comment: 'Most of the disk operations are just no-ops.'! (FakePacker getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !FakePacker methodsFor: 'transactions'! {void} beginConsistent: dirty {IntegerVar unused}! {void} endConsistent: dirty {IntegerVar unused} | agenda {Agenda | NULL} | InsideTransactionFlag fluidFetch ifFalse: [agenda _ myTurtle fetchAgenda. (agenda ~~ NULL and: [InsideAgenda fluidFetch not]) ifTrue: [InsideAgenda fluidBind: true during: [[agenda step] whileTrue]]]! {BooleanVar} insideCommit ^ false! {void} purge "Flush everything out to disk and remove all purgeable imaged objects from memory. This doesn't clear the ShepherdMap table. This will have to be a weak table, and then the destruction of a shepherd or shepherdStub should remove it from myShepherdMap."! {void} purgeClean: noneLocked {BooleanVar unused default: false} "No shepherds are clean, so no-op."! ! !FakePacker methodsFor: 'shepherds'! {void} destroyFlock: info {FlockInfo} "Queue destroy of the given flock. dismantle it immediately in the FakePacker." self knownBug. "This needs to stack shepherds for deletion after all agenda items." info markDestroyed. info getShepherd dismantle! {void} diskUpdate: info {FlockInfo | NULL} "The flock identified by token is Dirty!! On some later commit, write it to the disk."! {void} dismantleFlock: info {FlockInfo} "Tehre are no local data-structures." "info markDismantled."! {void} dropFlock: token {Int32} "No prob."! {void} forgetFlock: info {FlockInfo} "Yeah. Right."! {Turtle} getInitialFlock ^ myTurtle! {UInt32} nextHashForEqual "Shepherds use a sequence number for their hash. Return the next one and increment. This should actually spread the hashes." "This actually needs to roll over the UInt32 limit." myCount _ myCount + 1. ^ myCount! {void} rememberFlock: info {FlockInfo} "There are now persistent pointers to the shepherd represented by token."! {void} storeAlmostNewShepherd: shep {Abraham unused} "Do nothing"! {void} storeInitialFlock: turtle {Abraham unused} with: protocol {XcvrMaker unused} with: cookbook {Cookbook unused} Heaper BLAST: #MustBeRealDiskManager! {void} storeNewFlock: shep {Abraham} "Shep just got created!! On some later commit, assign it to a snarf and write it to the disk." | info {FlockInfo} | shep fetchInfo == NULL assert: 'Must not have an info yet'. "Create a FlockInfo to make the FlockTable registration happy." info _ FlockInfo make: shep with: myCount negated. shep flockInfo: info.! {void} storeTurtle: turtle {Turtle} myTurtle _ turtle! ! !FakePacker methodsFor: 'stubs'! {Abraham} fetchCanonical: hash {UInt32 unused} with: snarfID {SnarfID unused} with: index {Int32 unused} "If something is already imaged at that location, then return it. If there is already an existing stub with the same hash at a different location, follow them till we know that they are actually different objects." self unimplemented. ^NULL! {void} makeReal: info {FlockInfo unused} "Retrieve from the disk the flock at index within the specified snarf. Since stubs are canonical, and this only gets called by stubs, the existing stub will *become* the shepherd for the flock." self unimplemented! {void} registerStub: shep {Abraham unused} with: snarfID {SnarfID unused} with: index {Int32 unused} self unimplemented! ! !FakePacker methodsFor: 'protected: create'! create super create. myTurtle _ NULL. myCount _ UInt32Zero.! ! !FakePacker methodsFor: 'testing'! {BooleanVar} isFake ^ true! ! !FakePacker methodsFor: 'internals'! {void} destroyAbandoned! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FakePacker class instanceVariableNames: ''! (FakePacker getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !FakePacker class methodsFor: 'creation'! {DiskManager} make | packer {DiskManager} | packer _ FakePacker create. CurrentPacker fluidSet: packer. ^packer! !DiskManager subclass: #SnarfPacker instanceVariableNames: ' mySnarfInfo {SnarfInfoHandler} myTurtle {Turtle | NULL} myAllocationSnarf {SnarfID} mySnarfMap {MuTable of: IntegerPos with: SnarfRecord} myFlocks {SetTable of: IntegerPos and: FlockInfo} myNewFlocks {IntegerTable of: FlockInfo} myLastNewCount {IntegerVar} myNewEstimate {IntegerVar} myDestroyedFlocks {MuArray of: Abraham} myUrdiView {UrdiView star} myUrdi {Urdi star} myXcvrMaker {XcvrMaker} myBook {Cookbook} myNextHash {Counter} myConsistentCount {IntegerVar} myInsideCommit {BooleanVar} myDestroyCount {IntegerVar} myPurgeror {SanitationEngineer} myRepairer {LiberalPurgeror}' classVariableNames: ' DebugSizes {Collection smalltalk} LRUCount {Int32} ' poolDictionaries: '' category: 'Xanadu-Snarf'! SnarfPacker comment: 'Should myFlocks contain full flockInfos for forwarded flocks? Both the flags and the size mean nothing. A SnarfPacker maintains the relationship between Shepherds and the set of snarfs representing the disk. A SnarfPacker assigns flocks to snarfs based loosely on the flocks''s Shepherd''s preferences. When a flock changes, it informs the SnarfPacker. When the SnarfPacker decides to write to the disk, it ensures that the changed objects still fit in their snarf (migrating them if necessary), writes them to the snarf, then writes out the snarf. mySnarfInfo {MuTable of: XuInteger} - How much space remains in each snarf. mySnarfMap {MuTable of: SnarfRecord} - Map from snarfIDs to a SnarfRecord that handles that snarf. myChangedSnarfs {MuSet of: XuInteger} - The IDs for all snarfs in which an imaged flock has changed. myFlocks {SetTable of: XuInteger and: FlockInfo} - Indexed by Abraham hash, contains all FlockInfos that refer to flocks in memory. Multiple infos may refer to the same flock if it is referenced through forwarding. The only info considered to have the correct state wrt its flocks suitability for purging is the info pointed to by its Abraham. myInsideCommit {BooleanVar} - True while writing new and changed flocks to disk to prevent purging, and during purgeClean to prevent recursive call through Purgeror recycling.'! (SnarfPacker getOrMakeCxxClassDescription) friends: 'friend class ResetCommit_Bomb; friend class CBlockTrackingPacker;'; attributes: ((Set new) add: #CONCRETE; yourself)! !SnarfPacker methodsFor: 'shepherds'! {void} destroyFlock: info {FlockInfo} "Queue destroy of the given flock. The destroy will happen later." | flock {Abraham} | flock _ info getShepherd. (Heaper isDestructed: flock) ifTrue: [Heaper BLAST: #DestructedAbe]. info markDestroyed. info markForgotten ifTrue: [self recordUpdate: info]. info isNew ifTrue: [flock _ flock "just so I can set a breakpoint"] ifFalse: [mySnarfInfo setForgottenFlag: info snarfID with: true]. myDestroyedFlocks atInt: myDestroyedFlocks count introduce: flock! {void} diskUpdate: info {FlockInfo | NULL} InsideTransactionFlag fluidFetch assert: 'Must be inside transation'. "noop for unregistered flocks." info == NULL ifTrue: [^VOID]. info markContentsDirty ifTrue: [self recordUpdate: info].! {void} dismantleFlock: info {FlockInfo} "Turn the flock designated by info into a Pumpkin. It should have completed all dismantle actions." info markDismantled. info isNew ifFalse: [self thingToDo. "Go remove this from all the forwarded locations as well." (self getSnarfRecord: info snarfID) dismantleFlock: info].! {void} dropFlock: token {Int32} "The flock is being removed from memory. For now, this is an error if the flock has been updated. If the flock has been forgotten, then it will be dismantled when next it comes in from disk. Because of forwarding, there may be many FlockInfos refering to the flock if it is not new." | info {FlockInfo} | info := FlockInfo getInfo: token. (info isNew or: [info isForwarded]) ifTrue: [myNewFlocks intRemove: info index]. info isNew ifFalse: [info isForgotten ifFalse: [Heaper BLAST: #OnlyRemoveUnchangedFlocks]. (myFlocks stepperAtInt: info flockHash) forEach: [:oi {FlockInfo} | oi token == token ifTrue: [myFlocks wipe.IntegerVar: info flockHash with: oi]]]. FlockInfo removeInfo: token! {void} forgetFlock: info {FlockInfo} "Remember that there are no more persistent pointers to the shepherd represented by info. If it gets manually deleted, dismantle it immediately. If it gets garbage collected, remember to dismantle it when it comes back in from the disk." InsideTransactionFlag fluidFetch assert: 'Must be inside transation'. info markForgotten ifTrue: [self recordUpdate: info]. mySnarfInfo setForgottenFlag: info snarfID with: true. self thingToDo. "Don't rewrite the entire flock if it has only been forgotten."! {Turtle} getInitialFlock "Return the starting object for the entire backend. This will be the 0th flock in the first snarf following the snarfInfo tables." | handler {SnarfHandler} stream {XnReadStream} rcvr {Rcvr} protocol {char star} cookbook {char star} agenda {Agenda} | myTurtle ~~ NULL ifTrue: [^myTurtle]. handler _ self getReadHandler: mySnarfInfo snarfInfoCount. rcvr _ TextyXcvrMaker makeReader: (stream _ handler readStream: Int32Zero). protocol _ rcvr receiveString. cookbook _ rcvr receiveString. rcvr destroy. stream destroy. self releaseReadHandler: handler. myXcvrMaker _ ProtocolBroker diskProtocol: protocol. myBook _ Cookbook make.String: cookbook. protocol delete. cookbook delete. myTurtle _ (self getFlock: mySnarfInfo snarfInfoCount with: 1) cast: Turtle. myTurtle setProtocol: myXcvrMaker with: myBook. myNextHash _ myTurtle counter. self knownBug. "this agendaItem stepping should get done, but right now it ends up happening before the backend is initialized /ravi/10/22/92/" "agenda := myTurtle fetchAgenda. agenda ~~ NULL ifTrue: [InsideAgenda fluidBind: true during: [[myTurtle getAgenda step] whileTrue]]." self destroyAbandoned. ^myTurtle! {UInt32} nextHashForEqual "Shepherds use a sequence number for their hash. Return the next one and increment. This should actually spread the hashes." myNextHash == NULL ifTrue: [Heaper BLAST: #UninitializedPacker]. myNextHash increment. " skip sequence numbers for the many object allocated at backend creation time that are likely to still be around." (myNextHash count bitAnd: 134217727) == UInt32Zero ifTrue: [myNextHash setCount: myNextHash count + 100000]. ^myNextHash count DOTasLong! {void} rememberFlock: info {FlockInfo} "There are now persistent pointers to the shepherd help by info." InsideTransactionFlag fluidFetch assert: 'Must be inside transation'. info markRemembered ifTrue: [self recordUpdate: info]! {void} storeAlmostNewShepherd: shep {Abraham unused} "Do nothing"! {void} storeInitialFlock: turtle {Abraham} with: protocol {XcvrMaker} with: cookbook {Cookbook} "A turtle just got created!! Write out a pseudo-forwarder that has all the protocol information encoded in the snarfID and index." | handler {SnarfHandler} length {Int32} xmtr {Xmtr} stream {XnWriteStream} | myTurtle _ turtle cast: Turtle. turtle fetchInfo == NULL assert: 'Must not have an info yet'. handler _ SnarfHandler make: (myUrdiView makeErasingHandle: mySnarfInfo snarfInfoCount). handler initializeSnarf. handler allocateCells: 1. length _ (String strlen: protocol id) + (String strlen: cookbook id) + 20. self hack. "The extra 20 is not a very good measure of overhead." handler at: Int32Zero allocate: length. stream _ handler writeStream: IntegerVar0. xmtr _ TextyXcvrMaker makeWriter: stream. xmtr sendString: protocol id. xmtr sendString: cookbook id. xmtr destroy. stream destroy. mySnarfInfo setSpaceLeft: handler snarfID with: handler spaceLeft. handler destroy. myBook _ cookbook. myXcvrMaker _ protocol. self commitView. self storeNewFlock: turtle.! {void} storeNewFlock: shep {Abraham} "Shep just got created!! On some later commit, assign it to a snarf and write it to the disk." | info {FlockInfo} newIndex {IntegerVar} | shep fetchInfo == NULL assert: 'Must not have an info yet'. "Put the flock at the next available location in myNewFlocks." newIndex _ myNewFlocks highestIndex + 1. newIndex < myLastNewCount ifTrue: [ myLastNewCount _ newIndex ]. info _ FlockInfo make: shep with: newIndex. myNewFlocks atInt: newIndex introduce: info. shep flockInfo: info.! ! !SnarfPacker methodsFor: 'stubs'! {Abraham} fetchCanonical: hash {UInt32} with: snarfID {SnarfID} with: index {Int32} "If something is already imaged at that location, then return it. If there is already an existing stub with the same hash at a different location, follow them till we know that they are actually different objects." | flockStep {Stepper} | "myFlocks may have several FlockInfos for the same flock if the flocks has been forwarded. The actual location of the flock is determined by the flockInfo that the shepherd points at." (flockStep _ myFlocks stepperAtInt: hash) forEach: [:info {FlockInfo} | (info ~~ NULL and: [info snarfID == snarfID and: [info index == index]]) ifTrue: [ flockStep destroy. ^info fetchShepherd]]. "Didn't find an info pointing to the same disk location, so resolve infos with the same hash to avoid forwarder aliasing." flockStep _ myFlocks stepperAtInt: hash. flockStep hasValue ifTrue: [| newLoc {FlockLocation} loc {FlockLocation} handler {SnarfHandler} | loc _ FlockLocation make: snarfID with: index. newLoc _ NULL. [(newLoc _ (handler _ self getReadHandler: loc snarfID) fetchForward: loc index) ~~ NULL] whileTrue: [self releaseReadHandler: handler. loc _ newLoc]. self releaseReadHandler: handler. flockStep forEach: [:info {FlockInfo} | | newInfo {FlockInfo} | info ~~NULL ifTrue:[ newInfo _ self resolveLocation: info. (loc snarfID == newInfo snarfID and: [loc index == newInfo index]) ifTrue: [ flockStep destroy. ^newInfo fetchShepherd]]]]. ^NULL! {void} makeReal: info {FlockInfo} "Retrieve from the disk the flock at index within the specified snarf. Since stubs are canonical, and this only gets called by stubs, the existing stub will *become* the shepherd for the flock." | stub {Abraham} handler {SnarfHandler} loc {FlockLocation | NULL} | stub _ info getShepherd. stub isStub assert: 'Only stubs can be made real'. ["myInsideCommit _ true." "to prevent purge during reification" handler _ self getReadHandler: info snarfID. loc _ handler fetchForward: info index. loc == NULL ifTrue: [| oldHash {UInt32} stream {XnReadStream} rcvr {Rcvr} | oldHash _ stub hashForEqual. (rcvr _ self makeRcvr: (stream _ handler readStream: info index)) receiveInto: stub. rcvr destroy. stream destroy. stub hashForEqual == oldHash assert: 'Hash must not change'. info setSize: (handler flockSize: info index). "Receiving the flock has cleared its info, so put it back" stub flockInfo: info] ifFalse: ["Forwarded. Register stub at the new location. We leave the old info in place so that later references through the forwarder." self addInfo: (FlockInfo make: stub getInfo with: loc snarfID with: loc index) with: stub]. self releaseReadHandler: handler. handler _ NULL] valueNowOrOnUnwindDo: (SnarfPacker bomb.ResetCommit: self). "If the flock is forwarded, then the first instantiate will just change the location of the stub. Retry." info getShepherd isStub ifTrue: [self makeReal: stub getInfo]! {void} registerStub: shep {Abraham} with: snarfID {SnarfID} with: index {Int32} shep isStub assert: 'Must be stub'. self addInfo: (FlockInfo remembered: shep with: snarfID with: index) with: shep! ! !SnarfPacker methodsFor: 'internals'! {void} addInfo: info {FlockInfo} with: shep {Abraham} "Add another flockInfo object to myFlocks with info about another location for shep." myFlocks atInt: shep hashForEqual store: info. shep flockInfo: info! {Int32} computeSize: flock {Abraham} "Send the snarf over a transmitter into a stream that just counts the bytes put into it." | specialist {TransferSpecialist} counter {XnWriteStream} xmtr {Xmtr} size {Int32} | counter _ CountStream make. specialist _ DiskCountSpecialist make: myBook. xmtr _ myXcvrMaker makeXmtr: specialist with: counter. xmtr sendHeaper: flock. size _ (counter cast: CountStream) size. xmtr destroy. "specialist destroy." counter destroy. ^size! {UrdiView} currentView "Return the current urdiView." ^myUrdiView! {void} destroyAbandoned "Destroy all forgotten flocks that are no longer in memory." true ifTrue: [^VOID]. [cerr << '+'] smalltalkOnly. mySnarfInfo snarfInfoCount almostTo: mySnarfInfo snarfCount do: [:snarfID {Int32} | | reset {BooleanVar} | reset _ false. "In case we run into unforgettable objects." [mySnarfInfo getForgottenFlag: snarfID] whileTrue: ["Clear the flag first so we'll catch newly forgotten shepherds." mySnarfInfo setForgottenFlag: snarfID with: false. (self forgottenFlocks: snarfID) stepper forEach: [:iD {IntegerPos} | | index {Int32} | index _ iD asIntegerVar DOTasLong. (self fetchInMemory: snarfID with: index) == NULL ifTrue: [(self getFlock: snarfID with: index) destroy. self endConsistent: IntegerVarZero] ifFalse: [reset _ true]]]. reset ifTrue: [mySnarfInfo setForgottenFlag: snarfID with: true]].! {void} forwardFlock: shep {Abraham} "Shep has grown too large for its current place. Treat it as just a new flock and give it another place." (shep isEqual: Pumpkin make) not assert: 'Only forward real Flocks'. shep getInfo forward: myNewFlocks highestIndex DOTasLong + 1. "So a weak dropFlock will do the right thing." myNewFlocks atInt: myNewFlocks highestIndex + 1 introduce: shep getInfo.! {SpecialistRcvr} makeRcvr: readStream {XnReadStream} ^myXcvrMaker makeRcvr: (DiskSpecialist make: myBook with: self) with: readStream! {SpecialistXmtr} makeXmtr: writeStream {XnWriteStream} ^myXcvrMaker makeXmtr: (DiskSpecialist make: myBook with: self) with: writeStream! {void} setHashCounter: aCounter {Counter} myNextHash _ aCounter! {void} testNewFlocks myNewFlocks stepper forEach: [:info {FlockInfo} | ]! ! !SnarfPacker methodsFor: 'transactions'! {void} beginConsistent: dirtyFlocks {IntegerVar} self checkInfos. InsideTransactionFlag fluidFetch ifFalse: [| dirtySnarfs {Int32} bytesPerSnarf {Int32} | dirtyFlocks = -1 ifTrue: [dirtySnarfs _ 10] ifFalse: [dirtySnarfs _ dirtyFlocks DOTasLong min: 20]. bytesPerSnarf _ myUrdiView getDataSizeOfSnarf: Int32Zero. "Now the dirtySnarfs from new flocks (including the mapCell)." dirtySnarfs _ dirtySnarfs + (myNewFlocks count * 8 + myNewEstimate // bytesPerSnarf) DOTasLong. "Now the dirtySnarfs from changed flocks." dirtySnarfs _ dirtySnarfs + mySnarfMap count DOTasLong. "Now a buffer for good measure." dirtySnarfs _ dirtySnarfs + SpareStageSpace cruftedSnarfsGuess. dirtySnarfs >= myUrdi usableStages ifTrue: [self makePersistent]]! {void} endConsistent: dirty {IntegerVar unused} | agenda {Agenda | NULL} | InsideTransactionFlag fluidFetch ifTrue: [^VOID]. "Measure all the new flocks from the previous consistent block." myLastNewCount to: myNewFlocks highestIndex do: [:i {IntegerVar} | | info {FlockInfo} | info _ (myNewFlocks intFetch: i) cast: FlockInfo. info ~~ NULL ifTrue: [| shep {Abraham} | shep _ info fetchShepherd. shep ~~ NULL ifTrue: [| size {Int32} | size _ self computeSize: shep. info setSize: size. myNewEstimate _ myNewEstimate + size "+ (size // 10)"]]]. myLastNewCount _ myNewFlocks highestIndex + 1. myConsistentCount _ myConsistentCount + 1. self hack. "Do all agenda items before any destroys so we don't need to worry about pointers from Agenda Items into the data structures." InsideAgenda fluidFetch ifTrue: [^VOID]. agenda _ myTurtle fetchAgenda. agenda ~~ NULL ifTrue: [InsideAgenda fluidBind: true during: [[agenda step] whileTrue]]. "Now dismantled destroyed flocks." myDestroyedFlocks isEmpty ifTrue: [^VOID]. InsideAgenda fluidBind: true during: [[myDestroyedFlocks isEmpty] whileFalse: [| shep {Abraham} | "The count of the table is used as the index to insert things at, so it get's manipulated carefully here." "The destroy table is LIFO so that recursive destruction is depth first (to queue size)." shep _ (myDestroyedFlocks intGet: myDestroyedFlocks count - 1) cast: Abraham. myDestroyedFlocks intRemove: myDestroyedFlocks count - 1. shep getInfo isForgotten ifTrue: [shep dismantle]. myDestroyCount _ myDestroyCount + 1]]. self checkInfos.! {BooleanVar} insideCommit ^myInsideCommit! {void} makePersistent "The virtual image in memory is now in a consistent state. Write the image of all changed or new Shepherds out to the disk in a single atomic action. The atomicity only happens on top of a real Urdi, however." self checkInfos. [myInsideCommit _ true. "Note which flocks still fit in their snarfs, and forwards ones that don't" self refitFlocks. "Assign all new and migrating flocks to a snarf in a GC safe fashion." IntegerVarZero to: myNewFlocks highestIndex do: [:i {IntegerVar} | | info {FlockInfo} | info _ (myNewFlocks intFetch: i) cast: FlockInfo. "IF we GC'd, flocks and their infos might have been removed." info ~~ NULL ifTrue: [| shep {Abraham} | "This might be the only strong pointer to the object!!" info markShepNull. shep _ info fetchShepherd. shep ~~ NULL ifTrue: [self assignSnarf: shep]]]. "Write out all the changes into URDI buffers." self flushFlocks. myNewFlocks destroy. myNewFlocks _ IntegerTable make: 500. self commitView. [Transcript show: '.'] smalltalkOnly. myNewEstimate _ IntegerVarZero] valueNowOrOnUnwindDo: (SnarfPacker bomb.ResetCommit: self). self checkInfos.! {void} purge "Flush everything out to disk and remove all purgeable imaged objects from memory." InsideTransactionFlag fluidFetch ifTrue: [^VOID]. self makePersistent. self purgeClean: true! {void} purgeClean: noneLocked {BooleanVar default: false} "purge all shepherds that are currently clean, not locked, not dirty, and purgeable. Purging just turns them into stubs, freeing all their flocks. Garbage collection can clean up the flocks and any stubs no longer pointed to by something in memory. Because infos for new flocks don't appear in myFlocks, this will not throw out any newFlocks (which will be marked dirty anyway). For each FlockInfo, we check that its flock refers to that exact instance to get correct information about its dirty state." | stackPtrs {PrimPtrTable} | myInsideCommit ifTrue: [^VOID]. [myInsideCommit _ true. "to prevent recursive call" [Transcript show: 'Starting purge...'] smalltalkOnly. noneLocked ifTrue: [stackPtrs _ PrimPtrTable make: 1] ifFalse: [stackPtrs _ StackExaminer pointersOnStack]. myFlocks stepper forEach: [:info {FlockInfo} | | shep {Abraham} | shep _ info fetchShepherd. [(shep ~~ NULL and: [shep fetchInfo == info and: [shep isStub not and: [(stackPtrs fetch: shep asOop) == NULL and: [shep isPurgeable and: [info isDirty not]]]]]) ifTrue: [shep becomeStub]] smalltalkOnly. 'if (shep && shep->fetchInfo() == info && !!shep->isStub() && (stackPtrs->fetch((Int32)(void*)shep) == NULL) && shep->isPurgeable() && !!info->isDirty()) { shep->becomeStub(); }' translateOnly.]] valueNowOrOnUnwindDo: (SnarfPacker bomb.ResetCommit: self). noneLocked ifFalse: [myRepairer setMustPurge]. [Transcript show: 'done.'; cr] smalltalkOnly! ! !SnarfPacker methodsFor: 'protected: destruction'! {void} destruct "Destroy all objects imaged from this snarf." myPurgeror destroy. (Heaper isDestructed: mySnarfMap) ifFalse: [mySnarfMap stepper forEach: [:rec {Heaper} | rec destroy]. mySnarfMap destroy]. "myFlocks getCategory ~= Heaper ifTrue: [myFlocks stepper forEach: [:info {FlockInfo} | (Heaper isDestructed: info) ifFalse: [info getShepherd flockInfo: NULL. info destroy]]. myFlocks destroy]. myNewFlocks getCategory ~= Heaper ifTrue: [myNewFlocks stepper forEach: [:info {FlockInfo} | (Heaper isDestructed: info) ifFalse: [info getShepherd flockInfo: NULL. info destroy]]. myNewFlocks destroy]." mySnarfInfo destroy. myXcvrMaker _ NULL. myBook destroy. myUrdiView destroy. myUrdi destroy. super destruct! ! !SnarfPacker methodsFor: 'private:'! {void} assignSnarf: shep {Abraham} "Find a snarf in which to fit shep. Then assign it to that location, and mark that snarf as changed." | size {Int32} rec {SnarfRecord} index {Int32} oldInfo {FlockInfo} | "Migrating flocks already have a size computed. Likewise new flocks that haven't changed since they were estimated." size _ shep getInfo oldSize. (shep getInfo isNew and: [shep getInfo isContentsDirty]) ifTrue: [size _ (self computeSize: shep)]. "Include the space for a slot in the snarf map table." size _ size + SnarfHandler mapCellOverhead. "Check that size fits in a snarf" Eric hack. "This assumes that all snarfs are the same size" size > (myUrdi getDataSizeOfSnarf: Int32Zero) ifTrue: [Heaper BLAST: #Overgrazed]. "Check in the snarf last allocated. Search for another (first up, then down) if it won't fit." size > (mySnarfInfo getSpaceLeft: myAllocationSnarf) ifTrue: [| limitSnarf {SnarfID} snarfID {SnarfID} | "First search upward." limitSnarf _ mySnarfInfo snarfCount. snarfID _ myAllocationSnarf + 1. [snarfID < limitSnarf and: [size > (mySnarfInfo getSpaceLeft: snarfID)]] whileTrue: [snarfID _ snarfID + 1]. "Then if we didn't find space, search downward." snarfID >= limitSnarf ifTrue: [limitSnarf _ mySnarfInfo snarfInfoCount - 1. snarfID _ myAllocationSnarf - 1. [snarfID > limitSnarf and: [size > (mySnarfInfo getSpaceLeft: snarfID)]] whileTrue: [snarfID _ snarfID - 1]. snarfID <= limitSnarf ifTrue: [Heaper BLAST: #DiskFull]]. myAllocationSnarf _ snarfID]. myAllocationSnarf >= mySnarfInfo snarfInfoCount assert: 'A real snarf'. shep getInfo isForgotten ifTrue: [mySnarfInfo setForgottenFlag: myAllocationSnarf with: true]. rec _ self getSnarfRecord: myAllocationSnarf. "Update the size information and such inside the per-snarf data-structure." index _ rec allocate: size with: shep. oldInfo _ shep getInfo. self addInfo: (FlockInfo make: oldInfo with: myAllocationSnarf with: index) with: shep. "Destroy the old location." (oldInfo isNew or: [oldInfo isForwarded]) ifTrue: [oldInfo isForwarded ifTrue: [myFlocks wipe.IntegerVar: oldInfo flockHash with: oldInfo]. myNewFlocks intWipe: oldInfo index. oldInfo destroy]. "Remember the space is gone" mySnarfInfo setSpaceLeft: myAllocationSnarf with: rec spaceLeft! {void} checkInfos "Perform the sanity check of the moment. Beware the compile cost of changing this comment." "myFlocks stepper forEach: [:info {FlockInfo} | info getShepherd]. myNewFlocks stepper forEach: [:info {FlockInfo} | info getShepherd]"! {void} commitState: flag {BooleanVar} "Used by ResetCommit bomb" myInsideCommit := flag! {void} commitView "Commit by destroying the current view and creating a new one." | newView {UrdiView} | myUrdiView commitWrite. mySnarfInfo destroy. mySnarfInfo _ NULL. myUrdiView becomeRead. newView _ myUrdi makeWriteView. myUrdiView destroy. myUrdiView _ newView. mySnarfInfo _ SnarfInfoHandler make: myUrdi with: myUrdiView! {Abraham | NULL} fetchInMemory: snarfID {SnarfID} with: index {Int32} "Return true if the object is on disk but not in memory." | handler {SnarfHandler} loc {FlockLocation | NULL} stream {XnReadStream} rcvr {SpecialistRcvr} hash {UInt32} cat {Category} | handler _ self getReadHandler: snarfID. loc _ handler fetchForward: index. loc~~ NULL ifTrue: [self releaseReadHandler: handler. ^NULL]. self hack. "This is partially reading in the flock in order to get its hash!! Ick!!" stream _ handler readStream: index. rcvr _ (self makeRcvr: stream) cast: SpecialistRcvr. ((cat _ rcvr receiveCategory) isEqualOrSubclassOf: Abraham) ifFalse: [self releaseReadHandler: handler. Heaper BLAST: #NonShepherd]. "Right now this keeps looking for an end-of-packet marker. Grrr." hash _ rcvr receiveUInt32. rcvr destroy. stream destroy. self releaseReadHandler: handler. ^self fetchCanonical: hash with: snarfID with: index.! {void} flushFlocks "Actually write all the changed and newly assigned flocks to the disk." mySnarfMap stepper forIndices: [:index {IntegerVar} :rec {SnarfRecord} | rec flushChanges. mySnarfMap intWipe: index. rec destroy]. mySnarfMap destroy. mySnarfMap _ IntegerTable make: 50.! {MuSet of: IntegerPos} forgottenFlocks: snarfID {SnarfID} "Return the set of indices to flocks in snarf snarfID that are forgotten." | result {MuSet of: IntegerPos} handler {SnarfHandler} | handler _ self getReadHandler: snarfID. result _ MuSet make. Int32Zero almostTo: handler mapCount do: [:i {Int32} | (handler isForgotten: i) ifTrue: [result store: i integer]]. self releaseReadHandler: handler. ^result! {Abraham} getFlock: snarfID {SnarfID} with: index {Int32} "Return a flock at a particular location. This needs to register the flock if it doesn't exist already." | stream {XnReadStream} rcvr {Rcvr} result {Abraham} handler {SnarfHandler} forward {FlockLocation} | handler _ self getReadHandler: snarfID. "Follow forwarders." forward _ handler fetchForward: index. forward ~~ NULL ifTrue: [^self getFlock: forward snarfID with: forward index]. rcvr _ self makeRcvr: (stream _ handler readStream: index). result _ rcvr receiveHeaper cast: Abraham. rcvr destroy. stream destroy. (handler isForgotten: index) ifTrue: [self addInfo: (FlockInfo forgotten: result with: snarfID with: index) with: result] ifFalse: [self addInfo: (FlockInfo remembered: result with: snarfID with: index) with: result]. result getInfo setSize: (handler flockSize: index). self releaseReadHandler: handler. handler _ NULL. ^result! {SnarfHandler} getReadHandler: snarfID {SnarfID} "Get the read handler on the snarf." (mySnarfInfo getSpaceLeft: snarfID) <= (myUrdiView getDataSizeOfSnarf: snarfID) assert: 'Handle must aready be initialized'. ^SnarfHandler make: (myUrdiView makeReadHandle: snarfID)! {SnarfRecord} getSnarfRecord: snarfID {SnarfID} "Return the snarfRecord for snarfID. The SnarfRecord must exist if there are changed flocks imaged out of that snarf, but might not otherwise. Create it if necessary." | rec {SnarfRecord} | rec _ (mySnarfMap intFetch: snarfID) cast: SnarfRecord. rec == NULL ifTrue: [| spaceLeft {Int32} | spaceLeft _ mySnarfInfo getSpaceLeft: snarfID. rec _ SnarfRecord make: snarfID with: self with: spaceLeft. mySnarfMap atInt: snarfID introduce: rec]. ^rec! {void} recordUpdate: info {FlockInfo} "The flock represented by info has changed. Record it in the bookkeeping data-structures. This must be called by all things that affect whether the flock gets rewritten to disk." "The following test should be unnecessary because infos for new flocks should already be dirty, so we shouldn't get here." info isNew not ifTrue: [(self getSnarfRecord: info snarfID) changedFlock: info index with: info getShepherd]! {void} refitFlocks "Make sure all flocks that have changed still fit in their snarfs. Add any that don't to myNewFlocks and return the table from their current locations to the newShepherds." mySnarfMap stepper forIndices: [:snarfID {IntegerVar} :rec {SnarfRecord} | rec refitFlocks. mySnarfInfo setSpaceLeft: snarfID DOTasLong with: rec spaceLeft]! {void} releaseReadHandler: handler {SnarfHandler} "Release the supplied snarfHandler and destroy it." handler isWritable not assert: 'Must be read handle'. handler destroy! {FlockInfo} resolveLocation: info {FlockInfo} "Make sure that the shepherd or stub at that location actually points at the real location for a shepherd. This will resolve forwarding pointers, but not instantiate any flocks." | newInfo {FlockInfo} loc {FlockLocation} handler {SnarfHandler} | info isNew not assert: 'No new flocks allowed'. loc _ NULL. newInfo _ info. [(loc _ (handler _ self getReadHandler: newInfo snarfID) fetchForward: newInfo index) ~~ NULL] whileTrue: [self releaseReadHandler: handler. newInfo _ FlockInfo make: info with: loc snarfID with: loc index. self addInfo: newInfo with: info getShepherd]. self releaseReadHandler: handler. ^newInfo! ! !SnarfPacker methodsFor: 'protected: creation'! create: urdi {Urdi} super create. myTurtle _ NULL. myXcvrMaker _ XcvrMaker make. "Put in a bogus protocol maker." myBook _ NULL. myUrdi _ urdi. myUrdiView _ urdi makeWriteView. mySnarfInfo _ SnarfInfoHandler make: urdi with: myUrdiView. myAllocationSnarf _ Int32Zero. mySnarfMap _ IntegerTable make: 50. myFlocks _ SetTable make: IntegerSpace make with: 501. myNewFlocks _ IntegerTable make: 500. myDestroyedFlocks _ MuArray array. myConsistentCount _ IntegerVarZero. myNextHash _ NULL. myInsideCommit _ false. myDestroyCount _ Int32Zero. myPurgeror _ Purgeror make: self. myRepairer _ LiberalPurgeror make: self. myNewEstimate _ IntegerVarZero. myLastNewCount _ IntegerVarZero. PersistentCleaner make. "AbandonDisk make: self."! ! !SnarfPacker methodsFor: 'smalltalk: testing'! consistentCount ^myConsistentCount! ! !SnarfPacker methodsFor: 'smalltalk: defaults'! {void} purgeClean self purgeClean: false! ! !SnarfPacker methodsFor: 'smalltalk: passe'! {void} consistent: dirty {IntegerVar} with: aBlock {BlockClosure} self passe. myInsideCommit not assert: 'Transaction are outside commit operations'. InsideTransactionFlag fluidFetch ifTrue: [aBlock value] ifFalse: [self makeConsistentBegin: dirty. InsideTransactionFlag fluidBind: true during: aBlock. self makeConsistentEnd]! ! !SnarfPacker methodsFor: 'testing'! {BooleanVar} isFake ^ false! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! SnarfPacker class instanceVariableNames: ''! (SnarfPacker getOrMakeCxxClassDescription) friends: 'friend class ResetCommit_Bomb; friend class CBlockTrackingPacker;'; attributes: ((Set new) add: #CONCRETE; yourself)! !SnarfPacker class methodsFor: 'smalltalk: init'! linkTimeNonInherited LRUCount _ 50.! ! !SnarfPacker class methodsFor: 'creation'! {DiskManager} initializeUrdiOnDisk: fname {char star} | anUrdi {Urdi} view {UrdiView} disk {DiskManager} | anUrdi _ Urdi urdi: fname with: LRUCount. view _ anUrdi makeWriteView. SnarfInfoHandler initializeSnarfInfo: anUrdi with: view. view commitWrite. view destroy. disk _ SnarfPacker create: anUrdi. CurrentPacker fluidSet: disk. ^CurrentPacker fluidGet! make: fname {char star} ^self create: (Urdi urdi: fname with: LRUCount)! ! !SnarfPacker class methodsFor: 'exceptions: private:'! bomb.ResetCommit: CHARGE {SnarfPacker} ^[CHARGE commitState: false]! !DiskManager subclass: #TestPacker instanceVariableNames: ' myNextHash {UInt32} myInitialFlock {Abraham} myFlocks {IntegerTable of: FlockInfo} myChangedFlocks {IntegerTable of: Abraham} myDestroyedFlocks {IntegerTable of: Abraham} myAlmostNewFlocks {MuSet of: Abraham} myNewFlocks {IntegerTable of: FlockInfo} myXcvrMaker {XcvrMaker} myCountDown {IntegerVar} myPersistInterval {IntegerVar} myDisk {IntegerTable of: UInt8Array} myBook {Cookbook} amCommitting {BooleanVar} blastOnError {BooleanVar}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Snarf'! TestPacker comment: 'Does not actually go to disk, but just tests that the protocol is being followed correctly. Some of these tests may make it into the real SnarfPacker, but some of them will remain debugging tools. Most operations only do enough real stuff to be able to check that they work. The TestPacker holds onto an IntegerTable of UInt8Arrays that contain the disk representations of all the flocks. It also holds myDisk contains a UInt8Array for every flock that made it to disk. They are assigned sequential numbers. myNewFlocks contains the flockInfos for new flocks, and thus contains the new flocks wimpily. myAlmostNewFlocks contains flocks that are under construction but have not yet finished. myDestroyedFlocks contains flocks that will be destroyed upon exiting the current consistent block. myChangedFlocks points strongly at flocks that must be rewritten to disk. '! (TestPacker getOrMakeCxxClassDescription) friends: 'friend class EndCommit_Bomb;'; attributes: ((Set new) add: #CONCRETE; yourself)! !TestPacker methodsFor: 'shepherds'! {void} destroyFlock: info {FlockInfo} "Queue destroy of the given flock. The destroy will probably happen later." | flock {Abraham} | flock _ info getShepherd cast: Abraham. "Check for destructed essentially" self mustKnowShepherd: info. self mustBeInsideTransaction. self mustNotBeCommitting. self countDown. info markDestroyed. info markForgotten ifTrue: [self recordUpdate: info]. myDestroyedFlocks atInt: myDestroyedFlocks count introduce: flock! {void} diskUpdate: info {FlockInfo} info == NULL ifTrue: [^VOID]. "noop for new shepherds." self mustKnowShepherd: info. self mustBeInsideTransaction. self mustNotBeCommitting. self countDown. info markContentsDirty ifTrue: [self recordUpdate: info] ifFalse: ["sanity check" info isNew ifTrue: [(myNewFlocks includesIntKey: info index) assert: 'Something is wrong'] ifFalse: [(myChangedFlocks includesIntKey: info index) assert: 'Something is wrong']]! {void} dismantleFlock: info {FlockInfo} "The flock designated by info has completed all dismantling actions; throw it off the disk." | flock {Abraham} | flock _ info getShepherd cast: Abraham. "Check for destructed essentially" self mustKnowShepherd: info. self mustNotBeCommitting. self countDown. info markDismantled. info isNew ifFalse: [myChangedFlocks atInt: info index store: Pumpkin make].! {void} dropFlock: token {Int32} | info {FlockInfo} | info := FlockInfo getInfo: token. info isNew ifTrue: [myNewFlocks intRemove: info index] ifFalse: [info isForgotten ifFalse: [Heaper BLAST: #OnlyRemoveUnchangedFlocks]. myChangedFlocks intWipe: info index. myFlocks intRemove: info index]. FlockInfo removeInfo: token! {void} forgetFlock: info {FlockInfo} self mustKnowShepherd: info. self mustBeInsideTransaction. self mustNotBeCommitting. self countDown. info markForgotten ifTrue: [self recordUpdate: info]! {Turtle} getInitialFlock ^myInitialFlock cast: Turtle! {UInt32} nextHashForEqual myNextHash _ myNextHash + 1. "This actually needs to roll over the UInt32 limit." ^myNextHash! {void} rememberFlock: info {FlockInfo} self mustBeInsideTransaction. self countDown. info markRemembered ifTrue: [self recordUpdate: info]! {void} storeAlmostNewShepherd: shep {Abraham} myAlmostNewFlocks store: shep! {void} storeInitialFlock: turtle {Abraham} with: protocol {XcvrMaker} with: cookbook {Cookbook} myInitialFlock := turtle. myXcvrMaker := protocol. myBook := cookbook. self storeNewFlock: turtle.! {void} storeNewFlock: shep {Abraham} "Shep just got created!! On some later commit, assign it to a snarf and write it to the disk." | info {FlockInfo} | shep fetchInfo == NULL ifFalse: [Heaper BLAST: #NewShepherdMustNotHaveInfo]. self countDown. myAlmostNewFlocks wipe: shep. info _ TestFlockInfo make: shep with: myNewFlocks highestIndex + 1. myNewFlocks atInt: myNewFlocks highestIndex + 1 introduce: info. shep flockInfo: info! ! !TestPacker methodsFor: 'private: testing'! {void} checkNewFlockIndices myNewFlocks stepper forIndices: [ :index {IntegerVar} :value {FlockInfo} | index DOTasLong = value index ifFalse: [Heaper BLAST: #NewFlockIndexDoesNotMatch]]! {void} committing: flag {BooleanVar} amCommitting := flag! {IntegerVar} countDown "Decrement the countdown and return its new value" myCountDown := myCountDown - 1. ^myCountDown! {void} mustBeInsideTransaction InsideTransactionFlag fluidFetch ifFalse: [blastOnError ifTrue: [Heaper BLAST: #MustBeInsideTransaction]. [cerr << 'Method '<< thisContext sender sender selector << ' must call ' << thisContext sender selector << ' inside a transaction '] smalltalkOnly. cerr << 'A consistent block is missing ']! {void} mustKnowShepherd: info {FlockInfo} "Check that I know about this shepherd" | t {Heaper} | info isNew ifTrue: [t := myNewFlocks intFetch: info index] ifFalse: [t := myFlocks intFetch: info index]. (t ~~ NULL and: [t isEqual: info]) ifFalse: [Heaper BLAST: #IncorrectFlockInfo]! {void} mustNotBeCommitting amCommitting ifTrue: [Heaper BLAST: #MustNotChangeDuringCommit]! {void} resetCountDown myCountDown := myPersistInterval.! ! !TestPacker methodsFor: 'stubs'! {Abraham} fetchCanonical: hash {UInt32 unused} with: snarfID {SnarfID unused} with: index {Int32} ^(myFlocks intFetch: index) cast: Abraham! {void} makeReal: info {FlockInfo} | stub {Abraham} oldHash {UInt32} stream {XnReadStream} rcvr {Rcvr} | stub := info getShepherd. stub isStub ifFalse: [Heaper BLAST: #MustBeAStub]. oldHash := stub hashForEqual. (rcvr _ self makeRcvr: (stream _ self readStream: info)) receiveInto: stub. rcvr destroy. stream destroy. stub hashForEqual == oldHash ifFalse: [Heaper BLAST: #HashMustNotChange]. info setSize: (self computeSize: info getShepherd). "Receiving the flock will have cleared its info, so put it back." stub flockInfo: info! {void} registerStub: shep {Abraham} with: snarfID {SnarfID} with: index {Int32} | info {FlockInfo} | shep isStub assert: 'Must be stub'. info _ TestFlockInfo remembered: shep with: snarfID with: index. shep flockInfo: info. myFlocks atInt: index introduce: info! ! !TestPacker methodsFor: 'private: streams'! {Int32} computeSize: flock {Abraham} "Send the snarf over a transmitter into a stream that just counts the bytes put into it." | counter {XnWriteStream} xmtr {Xmtr} size {Int32} | counter := CountStream make. xmtr _ self makeXmtr: counter. xmtr sendHeaper: flock. size _ (counter cast: CountStream) size. xmtr destroy. counter destroy. ^size! {SpecialistRcvr} makeRcvr: readStream {XnReadStream} ^myXcvrMaker makeRcvr: (DiskSpecialist make: myBook with: self) with: readStream! {SpecialistXmtr} makeXmtr: writeStream {XnWriteStream} ^myXcvrMaker makeXmtr: (DiskSpecialist make: myBook with: self) with: writeStream! {XnReadStream} readStream: info {FlockInfo} "Get a read stream on the disk contents of the info" ^XnReadStream make: ((myDisk intGet: info index) cast: UInt8Array)! {XnWriteStream} writeStream: info {FlockInfo} "Get a write stream on the disk contents of the info" | result {UInt8Array} | result := UInt8Array make: (self computeSize: info getShepherd). myDisk atInt: info index store: result. self hack. "You can't use gutsOf in something that will do an allocation." ^XnWriteStream make: result! ! !TestPacker methodsFor: 'private: disk'! {void} assignSnarf: shep {Abraham} | oldInfo {FlockInfo} snarf {SnarfID} | oldInfo := shep getInfo. snarf := myDisk highestIndex DOTasLong + 1. myDisk atInt: snarf store: (UInt8Array make: UInt32Zero). shep flockInfo: (TestFlockInfo make: oldInfo with: snarf with: snarf). "Destroy the old location if it is for a new flock (rather than forwarded)." oldInfo isNew ifTrue: [myNewFlocks intWipe: oldInfo index. oldInfo destroy. (shep getInfo cast: TestFlockInfo) updateContentsInfo]. oldInfo := NULL. myFlocks atInt: snarf introduce: shep getInfo. myChangedFlocks atInt: snarf store: shep! {void} flushChanges "Rewrite all flocks that have changed in this snarf." "check that all changed flocks are in fact in myChangedFlocks" | flocks {TableStepper} | myFlocks stepper forEach: [:info {TestFlockInfo} | (info fetchShepherd ~~ NULL and: [(info isNew not) and: [(info updateContentsInfo or: [info isContentsDirty]) and: [(myChangedFlocks includesIntKey: info snarfID) not]]]) ifTrue: [blastOnError ifTrue: [Heaper BLAST: #ShouldHaveDoneDiskUpdateOnChangedShepherd]. cerr << 'Shepherd ' << info fetchShepherd << ' with info ' << info << ' should have done a diskUpdate '. self recordUpdate: info]]. "actually write changed flocks to disk" (flocks := myChangedFlocks stepper) forEach: [:thing {Heaper} | thing cast: Pumpkin into: [:pumpkin | myDisk intWipe: flocks index] cast: Abraham into: [:shep | | inf {FlockInfo} | inf := shep fetchInfo. inf == NULL ifTrue: [Heaper BLAST: #ShepherdMustNotHaveNullFlockInfo]. inf index == flocks index DOTasLong ifTrue: [| xmtr {Xmtr} stream {XnWriteStream} | "Not forwarded." shep isStub ifTrue: [Heaper BLAST: #MustBeInstantiated]. (xmtr _ self makeXmtr: (stream _ self writeStream: inf)) sendHeaper: shep. xmtr destroy. stream destroy. (inf cast: TestFlockInfo) setContents: ((myDisk intFetch: inf index) cast: UInt8Array). inf commitFlags] ifFalse: ["We only get here for forwarded flocks." Heaper BLAST: #TestPackerDoesNotForward]]]. myChangedFlocks destroy. myChangedFlocks := IntegerTable make! {void} recordUpdate: info {FlockInfo} "The flock represented by info has changed. Record it in the bookkeeping data-structures. This must be called by all things that affect whether the flock gets rewritten to disk." | shep {Abraham} | info isNew not ifTrue: [(shep _ info fetchShepherd) ~~ NULL ifTrue: [(shep isEqual: Pumpkin make) ifTrue: [blastOnError ifTrue: [Heaper BLAST: #MustNotRecordChangesForPumpkins]. cerr << 'Pumpkin ' << info << ' tried to diskUpdate '. ^VOID]]. myChangedFlocks atInt: info index store: shep]! {void} refitFlocks "do nothing for now"! ! !TestPacker methodsFor: 'create'! create: blast {BooleanVar} with: persistInterval {IntegerVar} super create. myNextHash := UInt32Zero. myInitialFlock := NULL. myFlocks := IntegerTable make. myChangedFlocks := IntegerTable make. myDestroyedFlocks _ MuArray array. myAlmostNewFlocks := MuSet make. myNewFlocks := IntegerTable make. myXcvrMaker := NULL. myBook := NULL. myPersistInterval := persistInterval. self resetCountDown. myDisk := IntegerTable make. amCommitting := false. blastOnError := blast.! ! !TestPacker methodsFor: 'internals'! {UInt32} computeHash: flock {Abraham} "Compute a hash on the contents" | hasher {XnWriteStream} hash {UInt32} xmtr {SpecialistXmtr} | hasher := HashStream make. xmtr := self makeXmtr: hasher. xmtr sendHeaper: flock. hash := (hasher cast: HashStream) hash. xmtr destroy. hasher destroy. ^hash! ! !TestPacker methodsFor: 'smalltalk: defaults'! {void} purgeClean self purgeClean: false! ! !TestPacker methodsFor: 'transactions'! {void} beginConsistent: dirty {IntegerVar unused} InsideTransactionFlag fluidFetch ifFalse: [self countDown < IntegerVar0 ifTrue: [self makePersistent. self resetCountDown]]! {void} endConsistent: dirty {IntegerVar unused} | agenda {Agenda | NULL} | InsideTransactionFlag fluidFetch ifTrue: [^VOID]. myAlmostNewFlocks isEmpty ifFalse: [blastOnError ifTrue: [Heaper BLAST: #MustDoNewShepherdAfterDiskUpdate]. cerr << 'These flocks should have done a newShepherd: ' << myAlmostNewFlocks << ' '. myAlmostNewFlocks stepper forEach: [:each {Abraham} | each newShepherd]]. InsideAgenda fluidFetch ifTrue: [^VOID]. agenda _ (myInitialFlock cast: Turtle) fetchAgenda. agenda ~~ NULL ifTrue: [InsideAgenda fluidBind: true during: [[agenda step] whileTrue]]. myDestroyedFlocks isEmpty ifTrue: [^VOID]. InsideAgenda fluidBind: true during: [[myDestroyedFlocks isEmpty] whileFalse: [| flock {Abraham} | flock _ (myDestroyedFlocks intGet: myDestroyedFlocks count - 1) cast: Abraham. myDestroyedFlocks intRemove: myDestroyedFlocks count - 1. flock getInfo isForgotten ifTrue: [flock dismantle]]]! {BooleanVar} insideCommit ^ amCommitting! {void} makePersistent [amCommitting := true. self refitFlocks. myNewFlocks stepper forEach: [:info {FlockInfo} | | shep {Abraham} | (shep _ info fetchShepherd) ~~ NULL ifTrue: [self assignSnarf: shep]]. self flushChanges. myNewFlocks destroy. myNewFlocks := IntegerTable make: 500] valueNowOrOnUnwindDo: (TestPacker bomb.EndCommit: self)! {void} purge InsideTransactionFlag fluidFetch ifFalse: [self makePersistent. self purgeClean: true]! {void} purgeClean: noneLocked {BooleanVar default: false} | stackPtrs {PrimPtrTable} | [Transcript show: 'Starting purge...'] smalltalkOnly. noneLocked ifTrue: [stackPtrs _ PrimPtrTable make: 1] ifFalse: [stackPtrs _ StackExaminer pointersOnStack]. myFlocks stepper forEach: [ :info {FlockInfo} | | shep {Abraham} | shep := info fetchShepherd. [(shep ~~ NULL and: [shep isStub not and: [(stackPtrs fetch: shep asOop) == NULL and: [shep isPurgeable and: [info isDirty not]]]]) ifTrue: [shep becomeStub]] smalltalkOnly. 'if (shep && shep->fetchInfo() == info && !!shep->isStub() && (stackPtrs->fetch((Int32)(void*)shep) == NULL) && shep->isPurgeable() && !!info->isDirty()) { shep->becomeStub(); }' translateOnly.]. [Transcript show: 'done.'; cr] smalltalkOnly! ! !TestPacker methodsFor: 'smalltalk: passe'! {void} makeConsistent self passe. myAlmostNewFlocks isEmpty ifFalse: [blastOnError ifTrue: [Heaper BLAST: #MustDoNewShepherdAfterDiskUpdate]. cerr << 'These flocks should have done a newShepherd: ' << myAlmostNewFlocks << ' '. myAlmostNewFlocks stepper forEach: [ :each {Abraham} | each newShepherd]]. self countDown < IntegerVar0 ifTrue: [self makePersistent. self resetCountDown]! ! !TestPacker methodsFor: 'testing'! {BooleanVar} isFake ^ false! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TestPacker class instanceVariableNames: ''! (TestPacker getOrMakeCxxClassDescription) friends: 'friend class EndCommit_Bomb;'; attributes: ((Set new) add: #CONCRETE; yourself)! !TestPacker class methodsFor: 'exceptions: private:'! bomb.EndCommit: CHARGE {TestPacker star} ^[CHARGE committing: false]! ! !TestPacker class methodsFor: 'pseudo constructors'! {DiskManager} make: blast {BooleanVar} with: persistInterval {IntegerVar} | result {DiskManager} | result := self create: blast with: persistInterval. CurrentPacker fluidSet: result. ^result! !Emulsion subclass: #DiskManagerEmulsion instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-backend'! !DiskManagerEmulsion methodsFor: 'accessing'! {void star} fetchNewRawSpace: size {#size.U.t var} 'return CurrentPacker.fluidGet()->fluidSpace( (char *) fcalloc (size, sizeof(char)) );' translateOnly. [^CurrentPacker fluidGet fluidSpace: (Array new: size)] smalltalkOnly! {void star} fetchOldRawSpace ^CurrentPacker fluidGet fluidSpace! ! !DiskManagerEmulsion methodsFor: 'creation'! create super create! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DiskManagerEmulsion class instanceVariableNames: ''! !DiskManagerEmulsion class methodsFor: 'creation'! make ^ DiskManagerEmulsion new create! !Heaper subclass: #EdgeManager instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-edge'! EdgeManager comment: 'Manages the common code for regions which are represented as a sequence of EdgeTransitions. Each coordinate space should define a subclass which implements the appropriate methods, and then use it to do the various region operations. Clients of the region do not need to see any of these classes.'! (EdgeManager getOrMakeCxxClassDescription) friends: 'friend class EdgeSimpleRegionStepper; friend class EdgeAccumulator; '; attributes: ((Set new) add: #DEFERRED; add: #EQ; yourself)! !EdgeManager methodsFor: 'private:'! {EdgeAccumulator} edgeAccumulator: startsInside {BooleanVar} "Create an accumulator which takes edges and creates a region" ^EdgeAccumulator make: self with: startsInside! {EdgeStepper} edgeStepper: region {XnRegion} "Create a stepper for iterating through the edges of the region" ^EdgeStepper make: (self startsInside: region) not with: (self transitions: region) with: (self transitionsCount: region)! {TransitionEdge} lowerEdge: region {XnRegion} | transitions {PtrArray of: TransitionEdge} | transitions := self transitions: region. ((self startsInside: region) or: [(self transitionsCount: region) = Int32Zero]) ifTrue: [Heaper BLAST: #InvalidRequest]. ^(transitions fetch: Int32Zero) cast: TransitionEdge! {EdgeStepper} singleEdgeStepper: pos {Position} "Create a stepper for iterating through the edges of the region" ^EdgeStepper make: false not with: (self posTransitions: pos)! {TransitionEdge} upperEdge: region {XnRegion} | transitions {PtrArray of: TransitionEdge} transitionsCount {Int32} | transitions := self transitions: region. transitionsCount := self transitionsCount: region. ((self isBoundedRight: region) not or: [transitionsCount == Int32Zero]) ifTrue: [Heaper BLAST: #InvalidRequest]. ^(transitions fetch: (transitionsCount - 1)) cast: TransitionEdge! ! !EdgeManager methodsFor: 'testing'! {BooleanVar} hasMember: region {XnRegion} with: pos {Position} | edges {EdgeStepper} edge {TransitionEdge} result {BooleanVar} | edges := self edgeStepper: region. [(edge := edges fetch cast: TransitionEdge) ~~ NULL] whileTrue: [(edge follows: pos) ifTrue: [result := edges isEntering not. edges destroy. ^ result]. edges step]. result := edges isEntering not. edges destroy. ^ result! {BooleanVar} isBoundedLeft: region {XnRegion} "Same meaning as IntegerRegion::isBoundedLeft" ^(self startsInside: region) not! {BooleanVar} isBoundedRight: region {XnRegion} "Same meaning as IntegerRegion::isBoundedRight" ^(((self transitionsCount: region) bitAnd: 1) == Int32Zero) ~~ (self startsInside: region)! {BooleanVar} isEmpty: region {XnRegion} ^(self startsInside: region) not and: [(self transitionsCount: region) = Int32Zero]! {BooleanVar} isFinite: region {XnRegion} "Here is one place where the *infinite* of the infinite divisibility assumed by OrderedRegion about the full ordering comes in (see class comment). An interval whose left edge is not the same as the right edge is assumed to contain an infinite number of positions" | transitions {PtrArray of: TransitionEdge} transitionsCount {Int32} | transitions := self transitions: region. transitionsCount := self transitionsCount: region. ((self startsInside: region) or: [(transitionsCount bitAnd: 1) ~~ Int32Zero]) ifTrue: [^false]. Int32Zero almostTo: transitionsCount by: 2 do: [ :i {Int32} | (((transitions fetch: i) cast: TransitionEdge) isFollowedBy: ((transitions fetch: i + 1) cast: TransitionEdge)) ifFalse: [^false]]. ^true! {BooleanVar} isFull: region {XnRegion} ^(self startsInside: region) and: [(self transitionsCount: region) = Int32Zero]! {BooleanVar} isSimple: region {XnRegion} | testVal {Int32} | (self startsInside: region) ifTrue: [testVal _ 1] ifFalse: [testVal _ 2]. ^(self transitionsCount: region) <= testVal! {BooleanVar} isSubsetOf: me {XnRegion} with: other {XnRegion} | mine {EdgeStepper} others {EdgeStepper} result {BooleanVar} | (self isEmpty: other) ifTrue: [^self isEmpty: me]. mine := self edgeStepper: me. others := self edgeStepper: other. (mine hasValue or: [others hasValue]) ifFalse: [ result := mine isEntering or: [others isEntering not]. mine destroy. others destroy. ^ result]. (mine isEntering not and: [others isEntering]) ifTrue: [mine destroy. others destroy. ^false]. [mine hasValue and: [others hasValue]] whileTrue: [(others getEdge isGE: mine getEdge) not ifTrue: [(others isEntering not and: [mine isEntering not]) ifTrue: [mine destroy. others destroy. ^false]. others step] ifFalse: [(mine getEdge isGE: others getEdge) not ifTrue: [(others isEntering and: [mine isEntering]) ifTrue: [mine destroy. others destroy. ^false]. mine step] ifFalse: [others isEntering ~~ mine isEntering ifTrue: [mine destroy. others destroy. ^false]. others step. mine step]]]. result := ((mine hasValue and: [others isEntering]) or: [others hasValue and: [mine isEntering not]]) not. mine destroy. others destroy. ^ result! ! !EdgeManager methodsFor: 'enumerating'! {IntegerVar} count: region {XnRegion} "Because Edge Regions should only be used on infinitely divisible spaces (like rationals), if it's finite then it is bounded on both sides, and all the internal intervals are singletons" (self isFinite: region) ifFalse: [Heaper BLAST: #MustBeFinite]. ^(self transitionsCount: region) // 2! ! !EdgeManager methodsFor: 'accessing'! {XnRegion} asSimpleRegion: region {XnRegion} (self isSimple: region) ifTrue: [^region]. (self isBoundedLeft: region) ifTrue: [(self isBoundedRight: region) ifTrue: [^self makeNew: false with: ((PrimSpec pointer arrayWithTwo: (self lowerEdge: region) with: (self upperEdge: region)) cast: PtrArray)] ifFalse: [^self makeNew: false with: ((PrimSpec pointer arrayWith: (self lowerEdge: region)) cast: PtrArray)]] ifFalse: [(self isBoundedRight: region) ifTrue: [^self makeNew: true with: ((PrimSpec pointer arrayWith: (self upperEdge: region)) cast: PtrArray)] ifFalse: [^self makeNew: true with: PtrArray empty]]! {Position} greatestLowerBound: region {XnRegion} "The largest position such that no other positions in the region are any less than it. In other words, this is the lower bounding element. We choose to avoid the terms 'lowerBound' and 'upperBound' as their meanings in IntegerRegion are significantly different. Here, both 'all numbers >= 3' and 'all numbers > 3' have a 'greatestLowerBound' of 3 even though the latter doesn't include 3. To tell whether a bound is included, good old 'hasMember' should do a fine job." ^self edgePosition: (self lowerEdge: region)! {Position} leastUpperBound: region {XnRegion} "The smallest position such that no other positions in the region are any greater than it. In other words, this is the upper bounding element. We choose to avoid the terms 'lowerBound' and 'upperBound' as their meanings in IntegerRegion are significantly different. Here, both 'all numbers <= 3' and 'all numbers < 3' have a 'leastUpperBound' of 3 even though the latter doesn't include 3. To tell whether a bound is included, good old 'hasMember' should do a fine job." ^self edgePosition: (self upperEdge: region)! {XnRegion} simpleUnion: me {XnRegion} with: other {XnRegion} (self isEmpty: me) ifTrue: [^self asSimpleRegion: other]. (self isEmpty: other) ifTrue: [^self asSimpleRegion: me]. ((self isBoundedLeft: me) and: [self isBoundedLeft: other]) ifTrue: [((self isBoundedRight: me) and: [self isBoundedRight: other]) ifTrue: [^self makeNew: false with: ((PrimSpec pointer arrayWithTwo: ((self lowerEdge: me) floor: (self lowerEdge: other)) with: ((self upperEdge: me) ceiling: (self upperEdge: other))) cast: PtrArray)] ifFalse: [^self makeNew: false with: ((PrimSpec pointer arrayWith: ((self lowerEdge: me) floor: (self lowerEdge: other))) cast: PtrArray)]] ifFalse: [((self isBoundedRight: me) and: [self isBoundedRight: other]) ifTrue: [^self makeNew: true with: ((PrimSpec pointer arrayWith: ((self upperEdge: me) ceiling: (self upperEdge: other))) cast: PtrArray)] ifFalse: [^self makeNew: true with: PtrArray empty]]! ! !EdgeManager methodsFor: 'printing'! {void} printRegionOn: region {XnRegion} with: oo {ostream reference} (self isEmpty: region) ifTrue: [oo << '{}'] ifFalse: [ | edges {EdgeStepper} previous {TransitionEdge} | edges := self edgeStepper: region. (self isSimple: region) ifFalse: [oo << '{']. edges isEntering ifFalse: [oo << '(-inf']. previous := NULL. edges forEach: [ :edge {TransitionEdge} | edge printTransitionOn: oo with: edges isEntering with: (previous ~~ NULL and: [previous touches: edge]). previous := edge]. (self isBoundedRight: region) ifFalse: [oo << ' +inf)']. (self isSimple: region) ifFalse: [oo << '}']]! ! !EdgeManager methodsFor: 'operations'! {XnRegion} complement: region {XnRegion} ^self makeNew: (self startsInside: region) not with: (self transitions: region) with: (self transitionsCount: region)! {ScruSet of: XnRegion} distinctions: region {XnRegion} | result {MuSet} | (self isSimple: region) ifFalse: [Heaper BLAST: #InvalidRequest]. (self isEmpty: region) ifTrue: [^ImmuSet make with: region]. (self isFull: region) ifTrue: [^ImmuSet make]. (self transitionsCount: region) = 1 ifTrue: [^ImmuSet make with: region]. result := MuSet make. result store: (self makeNew: false with: ((PrimSpec pointer arrayWith: (self lowerEdge: region)) cast: PtrArray)). result store: (self makeNew: true with: ((PrimSpec pointer arrayWith: (self upperEdge: region)) cast: PtrArray)). ^result asImmuSet! {XnRegion} intersect: meRegion {XnRegion} with: otherRegion {XnRegion} | mine {EdgeStepper} others {EdgeStepper} result {EdgeAccumulator} resultReg {XnRegion} | (self isEmpty: otherRegion) ifTrue: [^otherRegion]. mine := self edgeStepper: meRegion. others := self edgeStepper: otherRegion. result := self edgeAccumulator: ((self startsInside: meRegion) and: [self startsInside: otherRegion]). [mine hasValue and: [others hasValue]] whileTrue: [ | me {TransitionEdge} other {TransitionEdge} | me := mine getEdge. other := others getEdge. (me isGE: other) not ifTrue: [others isEntering not ifTrue: [result edge: me]. mine step] ifFalse: [mine isEntering not ifTrue: [result edge: other]. others step]]. (mine hasValue and: [others isEntering not]) ifTrue: [result edges: mine]. (others hasValue and: [mine isEntering not]) ifTrue: [result edges: others]. mine destroy. others destroy. resultReg := result region. result destroy. ^ resultReg! {Stepper} simpleRegions: region {XnRegion} with: order {OrderSpec default: NULL} order ~~ NULL ifTrue: [self unimplemented]. ^EdgeSimpleRegionStepper make: self with: (self edgeStepper: region)! {XnRegion} unionWith: meRegion {XnRegion} with: otherRegion {XnRegion} | mine {EdgeStepper} others {EdgeStepper} result {EdgeAccumulator} resultReg {XnRegion} | (self isEmpty: otherRegion) ifTrue: [^meRegion]. mine := self edgeStepper: meRegion. others := self edgeStepper: otherRegion. result := self edgeAccumulator: ((self startsInside: meRegion) or: [self startsInside: otherRegion]). [mine hasValue and: [others hasValue]] whileTrue: [ | me {TransitionEdge} other {TransitionEdge} | me := mine getEdge. other := others getEdge. (me isGE: other) not ifTrue: [others isEntering ifTrue: [result edge: me]. mine step] ifFalse: [mine isEntering ifTrue: [result edge: other]. others step]]. (mine hasValue and: [others isEntering]) ifTrue: [result edges: mine]. (others hasValue and: [mine isEntering]) ifTrue: [result edges: others]. mine destroy. others destroy. resultReg := result region. result destroy. ^ resultReg! {XnRegion} with: meRegion {XnRegion} with: newPos {Position} | mine {EdgeStepper} others {EdgeStepper} result {EdgeAccumulator} resultReg {XnRegion} | mine := self edgeStepper: meRegion. others := self singleEdgeStepper: newPos. result := self edgeAccumulator: (self startsInside: meRegion). [mine hasValue and: [others hasValue]] whileTrue: [ | me {TransitionEdge} other {TransitionEdge} | me := mine getEdge. other := others getEdge. (me isGE: other) not ifTrue: [others isEntering ifTrue: [result edge: me]. mine step] ifFalse: [mine isEntering ifTrue: [result edge: other]. others step]]. (mine hasValue and: [others isEntering]) ifTrue: [result edges: mine]. (others hasValue and: [mine isEntering]) ifTrue: [result edges: others]. mine destroy. others destroy. resultReg := result region. result destroy. ^ resultReg! ! !EdgeManager methodsFor: 'protected:'! {Position} edgePosition: edge {TransitionEdge} "The position associated with the given edge. Blast if there is none" self subclassResponsibility! {XnRegion} makeNew: startsInside {BooleanVar} with: transitions {PtrArray of: TransitionEdge} "Make a new region of the right type" self subclassResponsibility! {XnRegion} makeNew: startsInside {BooleanVar} with: transitions {PtrArray of: TransitionEdge} with: count {Int32} "Make a new region of the right type" self subclassResponsibility! {PtrArray of: TransitionEdge} posTransitions: pos {Position} self subclassResponsibility! {BooleanVar} startsInside: region {XnRegion} self subclassResponsibility! {PtrArray of: TransitionEdge} transitions: region {XnRegion} self subclassResponsibility! {Int32} transitionsCount: region {XnRegion} self subclassResponsibility! ! !EdgeManager methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! !EdgeManager subclass: #RealManager instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-tumbler'! (RealManager getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !RealManager methodsFor: 'protected:'! {Position} edgePosition: edge {TransitionEdge} ^(edge cast: RealEdge) position! {XnRegion} makeNew: startsInside {BooleanVar} with: transitions {PtrArray of: TransitionEdge} ^RealRegion make: startsInside with: transitions! {XnRegion} makeNew: startsInside {BooleanVar} with: transitions {PtrArray of: TransitionEdge} with: count {Int32} ^self makeNew: startsInside with: ((transitions copy: count) cast: PtrArray)! {PtrArray of: TransitionEdge} posTransitions: pos {Position} self unimplemented. ^NULL "fodder"! {BooleanVar} startsInside: region {XnRegion} ^(region cast: RealRegion) startsInside! {PtrArray of: TransitionEdge} transitions: region {XnRegion} ^(region cast: RealRegion) secretTransitions! {Int32 INLINE} transitionsCount: region {XnRegion} ^(region cast: RealRegion) secretTransitions count! ! !RealManager methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !EdgeManager subclass: #SequenceManager instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-tumbler'! SequenceManager comment: 'Specialized object for managing TumblerSpace objects. Is a type so that inlining could potentially be used.'! (SequenceManager getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !SequenceManager methodsFor: 'protected:'! {Position} edgePosition: edge {TransitionEdge} ^(edge cast: SequenceEdge) sequence! {XnRegion} makeNew: startsInside {BooleanVar} with: transitions {PtrArray of: TransitionEdge} ^self makeNew: startsInside with: transitions with: transitions count! {XnRegion} makeNew: startsInside {BooleanVar} with: transitions {PtrArray of: TransitionEdge} with: count {Int32} ^SequenceRegion create: startsInside with: transitions with: count! {PtrArray of: TransitionEdge} posTransitions: pos {Position} ^ (PrimSpec pointer arrayWithTwo: (BeforeSequence make: (pos cast: Sequence)) with: (AfterSequence make: (pos cast: Sequence))) cast: PtrArray! {BooleanVar} startsInside: region {XnRegion} ^(region cast: SequenceRegion) startsInside! {PtrArray of: TransitionEdge} transitions: region {XnRegion} ^(region cast: SequenceRegion) secretTransitions! {Int32} transitionsCount: region {XnRegion} ^(region cast: SequenceRegion) secretTransitionsCount! ! !SequenceManager methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !Heaper subclass: #Encrypter instanceVariableNames: ' myPublicKey {UInt8Array | NULL} myPrivateKey {UInt8Array | NULL}' classVariableNames: 'AllEncrypterMakers {MuTable of: Sequence and: EncrypterMaker} ' poolDictionaries: '' category: 'Xanadu-lock'! Encrypter comment: 'An Encrypter is an instantiation of some public-key encryption algorithm, along with optional public and private keys. Each subclass implements a particular algorithm, such as Rivest-Shamir-Adelman, in response to the encryption, decryption, and key generation protocol. ** obsolete documentation ** The algorithm is identified by a Sequence naming it. Each concrete subclass must register itself during initialization time. This is handled by two macros, DECLARE_ENCRYPTER and DEFINE_ENCRYPTER. DECLARE_ENCRYPTER(AClassName) defines a function that can be used to create an instance. DEFINE_ENCRYPTER("identifier",AClassName) creates an EncrypterMaker parametrized with that "constructor" function pointer, and stores it in the system-wide table of EncrypterMakers. DECLARE_ENCRYPTER should be invoked in function scope (i.e. inside a linkTimeNonInherited class method) and DEFINE_ENCRYPTER should be invoked inside an Initializer (i.e. inside an initTimeNonInherited class method). The pseudo-constructor to make an Encrypter takes the PackOBits identifying the algorithm, and looks for a corresponding EncrypterMaker in the table. It then asks that EncrypterMaker to create an instance, with the given public and private keys. Encrypters are mutable objects. This allows you to create an Encrypter, generate new random keys for it, make a copy, remove its private key, and pass that out for public use.'! (Encrypter getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #EQ; yourself)! !Encrypter methodsFor: 'create'! create: publicKey {UInt8Array | NULL} with: privateKey {UInt8Array | NULL} super create. myPublicKey := publicKey. myPrivateKey := privateKey.! ! !Encrypter methodsFor: 'encrypting/decrypting'! {UInt8Array} decrypt: encrypted {UInt8Array} "Decrypt data with the current private key." self subclassResponsibility! {UInt8Array} encrypt: clear {UInt8Array} "Encrypt the given data with the current public key." self subclassResponsibility! ! !Encrypter methodsFor: 'keys'! {UInt8Array} privateKey myPrivateKey == NULL ifTrue: [Heaper BLAST: #NoPrivateKey]. ^myPrivateKey! {UInt8Array} publicKey myPublicKey == NULL ifTrue: [Heaper BLAST: #NoPublicKey]. ^myPublicKey! {void} randomizeKeys: seed {UInt8Array} "Generate a new pair of public and private keys using the given data as a random seed." self subclassResponsibility! {void} setPrivateKey: newKey {UInt8Array | NULL} "Change the private key." myPrivateKey := newKey.! {void} setPublicKey: newKey {UInt8Array | NULL} "Change the public key." myPublicKey := newKey.! ! !Encrypter methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Encrypter class instanceVariableNames: ''! (Encrypter getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #EQ; yourself)! !Encrypter class methodsFor: 'pseudo constructors'! make: identifier {Sequence} with: publicKey {UInt8Array default: NULL} with: privateKey {UInt8Array default: NULL} "Make an encrypter of the given type with the given public and private keys. Gets the requested EncrypterMaker out of the table and then asks it to make an encrypter with the given key. Fails with BLAST(NoSuchEncrypter) if it is not found." ScruTable problems.NotInTable handle: [ :boom | Heaper BLAST: #NoSuchEncrypter] do: [^((AllEncrypterMakers get: identifier) cast: EncrypterMaker) makeEncrypter: publicKey with: privateKey]! ! !Encrypter class methodsFor: 'smalltalk: macros'! DECLARE.U.ENCRYPTER: className {Symbol} "Only applies in C++"! DEFINE.U.ENCRYPTER: identifier {String} with: className {Symbol} self REQUIRES: Encrypter. self remember: (Sequence string: identifier) with: (Smalltalk at: className)! {Encrypter} invokeFunction: publicKey {Sequence| NULL} with: privateKey {Sequence | NULL} "In Smalltalk, the Encrypter class is used in place of the function pointer." ^self create: publicKey with: privateKey! ! !Encrypter class methodsFor: 'was protected'! {void} remember: identifier {Sequence} with: constructor {EncrypterConstructor var} | maker {EncrypterMaker} | maker := EncrypterMaker create: constructor. AllEncrypterMakers at: identifier introduce: maker.! ! !Encrypter class methodsFor: 'smalltalk: defaults'! make: identifier {Sequence} ^self make: identifier with: NULL with: NULL! make: identifier {Sequence} with: publicKey {Sequence} ^self make: identifier with: publicKey with: NULL! ! !Encrypter class methodsFor: 'smalltalk: init'! initTimeNonInherited self REQUIRES: SequenceSpace. self REQUIRES: MuTable. AllEncrypterMakers := MuTable make: SequenceSpace make.! linkTimeNonInherited AllEncrypterMakers := NULL.! !Encrypter subclass: #NoEncrypter instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-lock'! NoEncrypter comment: 'Does no encryption at all.'! (NoEncrypter getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !NoEncrypter methodsFor: 'create'! create: publicKey {UInt8Array | NULL} with: privateKey {UInt8Array | NULL} super create: publicKey with: privateKey.! ! !NoEncrypter methodsFor: 'encrypting/decrypting'! {UInt8Array} decrypt: encrypted {UInt8Array} ^encrypted! {UInt8Array} encrypt: clear {UInt8Array} ^clear copy cast: UInt8Array! ! !NoEncrypter methodsFor: 'keys'! {void} randomizeKeys: seed {UInt8Array unused} self setPublicKey: (UInt8Array string: 'public'). self setPrivateKey: (UInt8Array string: 'private').! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NoEncrypter class instanceVariableNames: ''! (NoEncrypter getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !NoEncrypter class methodsFor: 'smalltalk: init'! initTimeNonInherited self DEFINE.U.ENCRYPTER: 'NoEncrypter' with: #NoEncrypter! linkTimeNonInherited self DECLARE.U.ENCRYPTER: #NoEncrypter! ! !NoEncrypter class methodsFor: 'create'! {Encrypter} make: publicKey {UInt8Array | NULL} with: privateKey {UInt8Array | NULL} ^ self create: publicKey with: privateKey.! !Heaper subclass: #EncrypterMaker instanceVariableNames: 'myConstructor {EncrypterConstructor var}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-lock'! EncrypterMaker comment: 'Contains a pointer to a function used to create an instance of a particular kind of Encrypter. Each concrete Encrypter subclass should create a corresponding EncrypterMaker object and register it in a table, with the name of the encryption algorithm. This should be done using the DECLARE_ENCRYPTER and DEFINE_ENCRYPTER macros.'! (EncrypterMaker getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; yourself)! !EncrypterMaker methodsFor: 'create'! create: constructor {EncrypterConstructor var} super create. myConstructor := constructor.! ! !EncrypterMaker methodsFor: 'accessing'! {Encrypter} makeEncrypter: publicKey {UInt8Array | NULL} with: privateKey {UInt8Array | NULL} "Make an instance of this kind of encrypter, with the given public and private keys." ^myConstructor invokeFunction: publicKey with: privateKey! ! !EncrypterMaker methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! !Heaper subclass: #ExceptionRecord instanceVariableNames: ' myPromise {IntegerVar} myError {Int32}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! ExceptionRecord comment: 'myPromise is the number of the promise that caused this error. It will be the excuse for an Excused promise.'! (ExceptionRecord getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !ExceptionRecord methodsFor: 'accessing'! {ExceptionRecord} best: rec {ExceptionRecord | NULL} "Return the error most useful to the client for figuring out what happened. This returns the earliest cause of an error (typically a broken promise." rec == NULL ifTrue: [^self]. rec promise <= myPromise ifTrue: [^rec]. ^self! {Int32} error ^myError! {BooleanVar} isExcused ^myError == ExceptionRecord excused! {IntegerVar} promise ^myPromise! ! !ExceptionRecord methodsFor: 'creation'! create: promise {IntegerVar} with: error {Int32} super create. myPromise _ promise. myError _ error! ! !ExceptionRecord methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '(' << myPromise. myError == ExceptionRecord excused ifTrue: [oo << ', excused)'] ifFalse: [myError == ExceptionRecord typeMismatch ifTrue: [oo << ', typeMismatch)'] ifFalse: [myError == ExceptionRecord badCategory ifTrue: [oo << ', badCategory)']]]! ! !ExceptionRecord methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ExceptionRecord class instanceVariableNames: ''! (ExceptionRecord getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !ExceptionRecord class methodsFor: 'constant'! {Int32} badCategory ^PromiseManager problemNumber: 'BAD_CATEGORY' "BLAST(BAD_CATEGORY)"! {Int32} excused ^PromiseManager problemNumber: 'BROKEN_PROMISE' "BLAST(BROKEN_PROMISE)"! {Int32} typeMismatch ^PromiseManager problemNumber: 'TYPE_MISMATCH' "BLAST(TYPE_MISMATCH)"! {Int32} wasNull ^PromiseManager problemNumber: 'WAS_NULL' "BLAST(WAS_NULL)"! ! !ExceptionRecord class methodsFor: 'creation'! {ExceptionRecord} badCategory: promise {IntegerVar} ^self create: promise with: self badCategory! {ExceptionRecord} excuse: promise {IntegerVar} ^self create: promise with: self excused! {ExceptionRecord} mismatch: promise {IntegerVar} ^self create: promise with: self typeMismatch! {ExceptionRecord} wasNull: promise {IntegerVar} ^self create: promise with: self wasNull! !Heaper subclass: #ExponentialHashMap instanceVariableNames: ' domain {Int32} rBottoms {UInt32Array} rSizes {UInt32Array} dBottoms {UInt32Array} dSize {Int32}' classVariableNames: ' FastHashMap {PtrArray} HashBits {UInt32} TheExponentialMap {ExponentialHashMap} ' poolDictionaries: '' category: 'Xanadu-Collection-Grand'! (ExponentialHashMap getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !ExponentialHashMap methodsFor: 'mapping'! {UInt32} of: aHash {UInt32} | pieceIndex {Int32} | (aHash > domain) ifTrue: [ Heaper BLAST: #outOfDomain ]. pieceIndex _ aHash // dSize. ^ (rBottoms uIntAt: pieceIndex) + ((aHash - (dBottoms uIntAt: pieceIndex)) * (rSizes uIntAt: pieceIndex) // dSize)! ! !ExponentialHashMap methodsFor: 'creation'! create: numPieces {Int32} with: range {UInt32} | rBottom {UInt32} | super create. domain _ range. dSize _ range // numPieces. "Depends on image having UInt32 _ Integer." rBottoms _ UInt32Array make: numPieces. rSizes _ UInt32Array make: numPieces. dBottoms _ UInt32Array make: numPieces. rBottom _ UInt32Zero. UInt32Zero almostTo: numPieces do: [ :d {UInt32} | dBottoms at: d storeUInt: d * dSize. rBottoms at: d storeUInt: rBottom. rBottom _ self expFunc: d + 1 * dSize within: range. rSizes at: d storeUInt: rBottom - (rBottoms uIntAt: d)].! ! !ExponentialHashMap methodsFor: 'private: calculation'! {UInt32} expFunc: domElem {UInt32} within: range {UInt32} ^(range * ((2.0 raisedTo: domElem asFloat / range asFloat) - 1)) asInteger! ! !ExponentialHashMap methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ExponentialHashMap class instanceVariableNames: ''! (ExponentialHashMap getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !ExponentialHashMap class methodsFor: 'accessing'! {UInt32 INLINE} exponentialMap: aHash {UInt32} ^ (TheExponentialMap of: ((FHash fastHash.UInt32: aHash) bitAnd: HashBits)) bitAnd: HashBits! {UInt32 INLINE} hashBits ^ HashBits! ! !ExponentialHashMap class methodsFor: 'smalltalk: init'! initTimeNonInherited "ExponentialHashMap initTimeNonInherited" TheExponentialMap _ ExponentialHashMap create: 256 with: HashBits + 1. [| rand {RandomStepper} | rand _ RandomStepper make: 43 with: 11 with: 5. FastHashMap _ PtrArray nulls: 8. UInt32Zero to: 7 do: [:i {UInt32} | | array {UInt32Array} | array _ UInt32Array make: 256. UInt32Zero to: 255 do: [: j {UInt32} | array at: j storeUInt: rand value. rand step]. FastHashMap at: i store: array]] smalltalkOnly! linkTimeNonInherited "ExponentialHashMap linkTimeNonInherited" HashBits _ (1 bitShift: 30) - 1. TheExponentialMap _ NULL. [HashBits _ SmallInteger maxVal // 2 - 1] smalltalkOnly. [FastHashMap _ NULL] smalltalkOnly! !Heaper subclass: #FeAdminer instanceVariableNames: 'myAdminKM {FeKeyMaster}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-nkernel'! FeAdminer comment: 'A client interface for system administration operations. This object can only be obtained using a KeyMaster that has System Admin authority. '! (FeAdminer getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #ON.CLIENT; add: #EQ; yourself)! !FeAdminer methodsFor: 'administrivia'! {void CLIENT} acceptConnections: open {BooleanVar} "Essential. Enable or disable the ability of the Server to accept communications connections from client machines. Anyone who has received a GateKeeper or Server object will continue to stay connected, but no new such objects will be handed out" CurrentGrandMap fluidGet acceptConnections: open! {Stepper CLIENT of: FeSession} activeSessions "Essential. Return a list of all active sessions." ^FeSession allActive! {void CLIENT} execute: commands {PrimIntArray} "Essential. Execute a sequence of server configuration commands." | rc {Rcvr} next {Heaper | NULL} | self knownBug. "only accepts UInt8Arrays" rc := TextyXcvrMaker make makeRcvr: (TransferSpecialist make: (Cookbook make.String: 'boot')) with: (XnReadStream make: (commands cast: UInt8Array)). next := rc receiveHeaper. [next ~~ NULL] whileTrue: [next cast: Thunk into: [:thunk | thunk execute] others: []. next := rc receiveHeaper]. rc destroy! {void CLIENT} grant: clubID {ID} with: globalIDs {IDRegion} "Essential. Grant a Club the authority to assign global IDs on this Server." CurrentGrandMap fluidGet grant: clubID with: globalIDs! {TableStepper CLIENT of: ID and: IDRegion} grants: clubIDs {IDRegion default: NULL} with: globalIDs {IDRegion default: NULL} "Essential. List who has been granted authority to various regions of the global IDSpace on this Server." ^CurrentGrandMap fluidGet grants: clubIDs with: globalIDs! {BooleanVar CLIENT} isAcceptingConnections "Essential. Whether the Server is accepting communications connections from client machines. " ^CurrentGrandMap fluidGet isAcceptingConnections! {void CLIENT} shutdown "Essential. Shutdown the Server immediately, taking down all the connections and writing all current changes to disk." [DiskManager] USES. CurrentPacker fluidFetch purge. ServerLoop scheduleTermination.! ! !FeAdminer methodsFor: 'smalltalk: passe'! {void} clearProfile self passe "rc file"! {void} consistencyCheck self passe "rc file"! {FeLockSmith} defaultLockSmith self passe! {void} disableAccess: clubID {ID} "Disable login access to a Club, by revoking its direct membership of the System Access Club" self passe. "see FeServer"! {void} enableAccess: clubID {ID} self passe. "see FeServer"! {void} nameClub: name {Sequence} with: clubID {ID} self passe. "see FeServer"! {void} renameClub: oldName {PackOBits} with: newName {PackOBits} self passe. "see FeServer"! {void} setDefaultLockSmith: lockSmith {FeLockSmith} self passe! {void} shutDown self passe "shutdown"! {void} unnameClub: name {PackOBits} self passe. "see FeServer"! {void} writeProfile self passe "rc file"! ! !FeAdminer methodsFor: 'security'! {FeLockSmith CLIENT} gateLockSmith "Essential. The LockSmith which hands out locks when a client tries to login through the GateKeeper with an invalid Club ID or name." [BeGrandMap] USES. ^(FeLockSmith spec wrap: CurrentGrandMap fluidGet gateLockSmithEdition) cast: FeLockSmith! {void CLIENT} setGateLockSmith: lockSmith {FeLockSmith} "Essential. Set the LockSmith which creates locks to hand out when a client tries to login with an invalid Club ID or name through the GateKeeper." [BeGrandMap] USES. CurrentGrandMap fluidFetch setGateLockSmithEdition: lockSmith edition! ! !FeAdminer methodsFor: 'smalltalk: defaults'! {TableStepper CLIENT of: ID and: IDRegion} grants ^self grants: NULL with: NULL! {TableStepper CLIENT of: ID and: IDRegion} grants: clubIDs {IDRegion default: NULL} ^self grants: clubIDs with: NULL! ! !FeAdminer methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FeAdminer class instanceVariableNames: ''! (FeAdminer getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #ON.CLIENT; add: #EQ; yourself)! !FeAdminer class methodsFor: 'create'! {FeAdminer CLIENT} make FeKeyMaster assertAdminAuthority. ^self create! ! !FeAdminer class methodsFor: 'smalltalk: system'! info.stProtocol "{void CLIENT} acceptConnections: open {BooleanVar} {Stepper CLIENT of: FeSession} activeSessions {void CLIENT} execute: commands {PrimIntegerArray} {FeLockSmith CLIENT} gateLockSmith {void CLIENT} grant: clubID {ID} with: globalIDs {IDRegion} {TableStepper CLIENT of: ID and: IDRegion} grants {TableStepper CLIENT of: ID and: IDRegion} grants: clubIDs {IDRegion default: NULL} {TableStepper CLIENT of: ID and: IDRegion} grants: clubIDs {IDRegion default: NULL} with: globalIDs {IDRegion default: NULL} {BooleanVar CLIENT} isAcceptingConnections {void CLIENT} setGateLockSmith: lockSmith {FeLockSmith} {void CLIENT} shutDown "! !Heaper subclass: #FeArchiver instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-sysadm'! FeArchiver comment: 'Used for transferring information to and from external storage medium. This protocol is still expected to evolve.'! (FeArchiver getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #ON.CLIENT; add: #EQ; yourself)! !FeArchiver methodsFor: 'accessing'! {FeEdition CLIENT} archive: works {FeEdition} with: medium {FeEdition} "Essential. Copy the entire contents of a set of Works onto secondary storage. Requires read permission on all the Works (or the authority of the System Archive Club, which can read anything). The medium is an Edition describing the kind of device on which to write the backup. The result and the list of Works are wrapped as Sets, the medium as a StorageMedium. Returns the set of Works which were in fact successfully backed up." Dean shouldImplement. ^NULL "fodder"! {void CLIENT} markArchived: edition {FeEdition} "Essential. Mark the contents of a set of Works as archived so that they can be discarded from the online disk. Requires System Admin authority." Dean shouldImplement! {FeEdition CLIENT} restore: works {FeEdition | NULL} with: medium {FeEdition} "Essential. Restore information from a backup tape. If a set of Works is specified, then restores only them from the backup medium, otherwise just reads the entire contents. Must have edit authority on Works which are restored. (Is this the right authority? What to do about history?) Returns the Works which were restored from tape." Dean shouldImplement. ^NULL "fodder"! ! !FeArchiver methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FeArchiver class instanceVariableNames: ''! (FeArchiver getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #ON.CLIENT; add: #EQ; yourself)! !FeArchiver class methodsFor: 'create'! {FeArchiver CLIENT} make ^self create! ! !FeArchiver class methodsFor: 'smalltalk: system'! info.stProtocol "{FeEdition CLIENT} archive: works {FeEdition} with: medium {FeEdition} {void CLIENT} markArchived: edition {FeEdition} {FeEdition CLIENT} restore: works {FeEdition | NULL} with: medium {FeEdition} "! !Heaper subclass: #FeBundle instanceVariableNames: 'myRegion {XnRegion}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-nkernel'! FeBundle comment: 'Describes a single chunk of information from an Edition'! (FeBundle getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; yourself)! !FeBundle methodsFor: 'protected: create'! create: region {XnRegion} super create. myRegion := region.! ! !FeBundle methodsFor: 'accessing'! {XnRegion CLIENT} region "Essential. The positions in the Edition for which I describe the contents" ^myRegion! ! !FeBundle methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FeBundle class instanceVariableNames: ''! (FeBundle getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; yourself)! !FeBundle class methodsFor: 'smalltalk: system'! info.stProtocol "{XnRegion CLIENT} region "! !FeBundle subclass: #FeArrayBundle instanceVariableNames: ' myArray {PrimArray} myOrder {OrderSpec}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-nkernel'! FeArrayBundle comment: 'Describes a chunk of information represented as an array. The number of elements in the array are the same as my region, and they are ordered according to OrderSpec given to the retrieve operation which produced me.'! (FeArrayBundle getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !FeArrayBundle methodsFor: 'accessing'! {PrimArray CLIENT} array "Essential. The array of elements in this bundle" ^myArray copy! {OrderSpec CLIENT} ordering "Essential. The order relating the elements in the array to the positions in the region." ^myOrder! ! !FeArrayBundle methodsFor: 'private: create'! create: region {XnRegion} with: array {PrimArray} with: order {OrderSpec} super create: region. myArray := array. myOrder _ order! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FeArrayBundle class instanceVariableNames: ''! (FeArrayBundle getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !FeArrayBundle class methodsFor: 'create'! make: region {XnRegion} with: array {PrimArray} with: order {OrderSpec} ^self create: region with: array with: order! ! !FeArrayBundle class methodsFor: 'smalltalk: system'! info.stProtocol "{PrimArray CLIENT} array {OrderSpec CLIENT} order "! !FeBundle subclass: #FeElementBundle instanceVariableNames: 'myElement {FeRangeElement}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-nkernel'! FeElementBundle comment: 'Describes a region of an Edition in which all indices in my region hold the same RangeElement.'! (FeElementBundle getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !FeElementBundle methodsFor: 'accessing'! {FeRangeElement CLIENT} element "Essential. The RangeElement which is at every position in my region" ^myElement! ! !FeElementBundle methodsFor: 'private: create'! create: region {XnRegion} with: element {FeRangeElement} super create: region. myElement := element! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FeElementBundle class instanceVariableNames: ''! (FeElementBundle getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !FeElementBundle class methodsFor: 'create'! make: region {XnRegion} with: element {FeRangeElement} ^self create: region with: element! ! !FeElementBundle class methodsFor: 'smalltalk: system'! info.stProtocol "{FeRangeElement CLIENT} element "! !FeBundle subclass: #FePlaceHolderBundle instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-nkernel'! FePlaceHolderBundle comment: 'Describes a region of an Edition in which all indices in my region have a distinct PlaceHolder.'! (FePlaceHolderBundle getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !FePlaceHolderBundle methodsFor: 'private: create'! create: region {XnRegion} super create: region.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FePlaceHolderBundle class instanceVariableNames: ''! (FePlaceHolderBundle getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !FePlaceHolderBundle class methodsFor: 'create'! make: region {XnRegion} ^self create: region! !Heaper subclass: #FeDetector instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-detect'! FeDetector comment: 'This generic superclass for detectors is so the comm system can tell what things are detectors.'! (FeDetector getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #EQ; yourself)! !FeDetector methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! !FeDetector subclass: #FeFillDetector instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-detect'! FeFillDetector comment: 'Client defines subclasses and passes in an instance in order to be notified of new results from Edition::rangeTranscluders () or RangeElement::transcluders (). If passed to Edition::addFillRangeDetector, this subclass merely passes in the Editions in the range one by one, though they may appear in the result in batches.'! (FeFillDetector getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; yourself)! !FeFillDetector methodsFor: 'triggering'! {void CLIENT} filled: newIdentity {FeRangeElement} "A single PlaceHolder has been filled to become another kind of RangeElement" self subclassResponsibility! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FeFillDetector class instanceVariableNames: ''! (FeFillDetector getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; yourself)! !FeFillDetector class methodsFor: 'smalltalk: system'! info.stProtocol "{NOWAIT CLIENT} filled: newIdentity {PrRangeElement} "! !FeFillDetector subclass: #CommFillDetector instanceVariableNames: ' myManager {PromiseManager} myNumber {IntegerVar} myTarget {FeRangeElement}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! CommFillDetector comment: 'Send the detector events over comm.'! (CommFillDetector getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !CommFillDetector methodsFor: 'creation'! create: pm {PromiseManager} with: number {IntegerVar} with: target {FeRangeElement} super create. myManager _ pm. myNumber _ number. myTarget _ target! ! !CommFillDetector methodsFor: 'triggering'! {void} filled: newIdentity {FeRangeElement} "A single PlaceHolder has been filled to become another kind of RangeElement" myManager queueDetectorEvent: (FilledEvent make: myNumber with: newIdentity)! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CommFillDetector class instanceVariableNames: ''! (CommFillDetector getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !CommFillDetector class methodsFor: 'creation'! make: pm {PromiseManager} with: number {IntegerVar} with: target {FeRangeElement} ^self create: pm with: number with: target! !FeFillDetector subclass: #WorksTestFillDetector instanceVariableNames: ' myTag {Character star} myOutput {ostream star}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-nkernel'! (WorksTestFillDetector getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; add: #NOT.A.TYPE; yourself)! !WorksTestFillDetector methodsFor: 'triggering'! {void} filled: transclusion {FeRangeElement} [myOutput << myTag << transclusion << ' '] smalltalkOnly. '(*myOutput) << myTag << transclusion << "\n";' translateOnly.! ! !WorksTestFillDetector methodsFor: 'private: create'! create: oo {ostream reference} with: tag {Character star} super create. [myOutput := oo] smalltalkOnly. 'myOutput = &oo;' translateOnly. myTag := tag.! ! !WorksTestFillDetector methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! WorksTestFillDetector class instanceVariableNames: ''! (WorksTestFillDetector getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; add: #NOT.A.TYPE; yourself)! !WorksTestFillDetector class methodsFor: 'pseudo constructors'! {FeFillDetector} make: oo {ostream reference} with: tag {Character star} ^self create: oo with: tag.! !FeDetector subclass: #FeFillRangeDetector instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-detect'! FeFillRangeDetector comment: 'Client defines a subclass and passes it in to Edition::addFillRangeDetector, to be notified whenever PlaceHolders become any other kind of RangeElement.'! (FeFillRangeDetector getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; yourself)! !FeFillRangeDetector methodsFor: 'triggering'! {void CLIENT} rangeFilled: newIdentities {FeEdition} "Essential. Some of the PlaceHolders in the Edition on which I was placed have become something else. The Edition has their new identies as its RangeElements, though the keys may bear no relationship to those in the original Edition." self subclassResponsibility! ! !FeFillRangeDetector methodsFor: 'smalltalk: passe'! {void} allFilled: newIdentities {FeEdition} self passe "rangeFilled"! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FeFillRangeDetector class instanceVariableNames: ''! (FeFillRangeDetector getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; yourself)! !FeFillRangeDetector class methodsFor: 'smalltalk: system'! info.stProtocol "{NOWAIT CLIENT} rangeFilled: newIdentities {PrEdition} "! !FeFillRangeDetector subclass: #CommFillRangeDetector instanceVariableNames: ' myManager {PromiseManager} myNumber {IntegerVar} myTarget {FeEdition}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! CommFillRangeDetector comment: 'Send the detector events over comm.'! (CommFillRangeDetector getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !CommFillRangeDetector methodsFor: 'creation'! create: pm {PromiseManager} with: number {IntegerVar} with: target {FeEdition} super create. myManager _ pm. myNumber _ number. myTarget _ target! ! !CommFillRangeDetector methodsFor: 'triggering'! {void} rangeFilled: newIdentities {FeEdition} "Essential. Some of the PlaceHolders in the Edition on which I was placed have become something else. The Edition has their new identies as its RangeElements, though the keys may bear no relationship to those in the original Edition." myManager queueDetectorEvent: (RangeFilledEvent make: myNumber with: newIdentities)! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CommFillRangeDetector class instanceVariableNames: ''! (CommFillRangeDetector getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !CommFillRangeDetector class methodsFor: 'creation'! make: pm {PromiseManager} with: number {IntegerVar} with: target {FeEdition} ^self create: pm with: number with: target! !FeFillRangeDetector subclass: #WorksTestFillRangeDetector instanceVariableNames: ' myTag {Character star} myOutput {ostream star}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-nkernel'! (WorksTestFillRangeDetector getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; add: #NOT.A.TYPE; yourself)! !WorksTestFillRangeDetector methodsFor: 'triggering'! {void} rangeFilled: transclusions {FeEdition} [myOutput << myTag << transclusions << ' '] smalltalkOnly. '(*myOutput) << myTag << transclusions << "\n";' translateOnly.! ! !WorksTestFillRangeDetector methodsFor: 'private: create'! create: oo {ostream reference} with: tag {Character star} super create. [myOutput := oo] smalltalkOnly. 'myOutput = &oo;' translateOnly. myTag := tag.! ! !WorksTestFillRangeDetector methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! WorksTestFillRangeDetector class instanceVariableNames: ''! (WorksTestFillRangeDetector getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; add: #NOT.A.TYPE; yourself)! !WorksTestFillRangeDetector class methodsFor: 'pseudo constructors'! {FeFillRangeDetector} make: oo {ostream reference} with: tag {Character star} ^self create: oo with: tag.! !FeDetector subclass: #FeRevisionDetector instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-detect'! FeRevisionDetector comment: 'Client defines subclasses and passes in an instance in order to be notified of revisions to a Work'! (FeRevisionDetector getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; yourself)! !FeRevisionDetector methodsFor: 'triggering'! {void CLIENT} revised: work {FeWork} with: contents {FeEdition} with: author {ID} with: time {IntegerVar} with: sequence {IntegerVar} "Essential. The Work has been revised. Gives the Work, the current Edition, the author ID who had it grabbed, the sequence number of the revision to the Work, and the clock time on the Server (note that the clock time is only as reliable as the Server's operating system, which is usually not very)." self subclassResponsibility! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FeRevisionDetector class instanceVariableNames: ''! (FeRevisionDetector getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; yourself)! !FeRevisionDetector class methodsFor: 'smalltalk: system'! info.stProtocol "{NOWAIT CLIENT} revised: contents {PrEdition} with: author {PrID} with: time {PrInteger} with: sequence {PrInteger} "! !FeRevisionDetector subclass: #CommRevisionDetector instanceVariableNames: ' myManager {PromiseManager} myNumber {IntegerVar} myTarget {FeWork}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! CommRevisionDetector comment: 'Send the detector events over comm.'! (CommRevisionDetector getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !CommRevisionDetector methodsFor: 'creation'! create: pm {PromiseManager} with: number {IntegerVar} with: target {FeWork} super create. myManager _ pm. myNumber _ number. myTarget _ target! ! !CommRevisionDetector methodsFor: 'triggering'! {void} revised: work {FeWork} with: contents {FeEdition} with: author {ID} with: time {IntegerVar} with: sequence {IntegerVar} "Essential. The Work has been revised. Gives the Work, the current Edition, the author ID who had it grabbed, the sequence number of the revision to the Work, and the clock time on the Server (note that the clock time is only as reliable as the Server's operating system, which is usually not very)." myManager queueDetectorEvent: (RevisedEvent make: myNumber with: work with: contents with: author with: time with: sequence)! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CommRevisionDetector class instanceVariableNames: ''! (CommRevisionDetector getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !CommRevisionDetector class methodsFor: 'creation'! make: pm {PromiseManager} with: number {IntegerVar} with: target {FeWork} ^self create: pm with: number with: target! !FeDetector subclass: #FeStatusDetector instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-detect'! FeStatusDetector comment: 'Is notified of changes in the capability of a Work object.'! (FeStatusDetector getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; yourself)! !FeStatusDetector methodsFor: 'triggering'! {void CLIENT} grabbed: work {FeWork} with: author {ID} with: reason {IntegerVar} "Essential. The Work has been grabbed, or regrabbed." self subclassResponsibility! {void CLIENT} released: work {FeWork} with: reason {IntegerVar} "Essential. The revise capability of the Work has been lost." self subclassResponsibility! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FeStatusDetector class instanceVariableNames: ''! (FeStatusDetector getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; yourself)! !FeStatusDetector class methodsFor: 'smalltalk: system'! info.stProtocol "{Int32 CLIENT INLINE} EDIT.U.PERMISSION.U.CHANGED {Int32 CLIENT INLINE} KEYMASTER.U.CHANGED {Int32 CLIENT INLINE} SIGNATURE.U.AUTHORITY.CHANGED {void NOWAIT CLIENT} grabbed: work {PrWork} with: author {PrID} with: reason {PrInteger} {void NOWAIT CLIENT} released: work {PrWork} with: reason {PrInteger} "! ! !FeStatusDetector class methodsFor: 'constants'! {Int32 CLIENT INLINE} EDIT.U.PERMISSION.U.CHANGED "The reason for the change was a change in the permissions required to edit the Work" ^4! {Int32 CLIENT INLINE} KEYMASTER.U.CHANGED "The reason for the change was a change in authority of the KeyMaster in the Work" ^2! {Int32 CLIENT INLINE} SIGNATURE.U.AUTHORITY.CHANGED "The reason for the change was a change in signature authority of the CurrentAuthor" ^1! !FeStatusDetector subclass: #CommStatusDetector instanceVariableNames: ' myManager {PromiseManager} myNumber {IntegerVar} myTarget {FeWork}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! CommStatusDetector comment: 'Send the detector events over comm.'! (CommStatusDetector getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !CommStatusDetector methodsFor: 'creation'! create: pm {PromiseManager} with: number {IntegerVar} with: target {FeWork} super create. myManager _ pm. myNumber _ number. myTarget _ target! ! !CommStatusDetector methodsFor: 'triggering'! {void} grabbed: work {FeWork} with: author {ID} with: reason {IntegerVar} "Essential. The Work has been grabbed, or regrabbed." myManager queueDetectorEvent: (GrabbedEvent make: myNumber with: work with: author with: reason)! {void} released: work {FeWork} with: reason {IntegerVar} "Essential. The revise capability of the Work has been lost." myManager queueDetectorEvent: (ReleasedEvent make: myNumber with: work with: reason)! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CommStatusDetector class instanceVariableNames: ''! (CommStatusDetector getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !CommStatusDetector class methodsFor: 'creation'! make: pm {PromiseManager} with: number {IntegerVar} with: target {FeWork} ^self create: pm with: number with: target! !FeStatusDetector subclass: #WorksTestStatusDetector instanceVariableNames: ' myTag {Character star} myOutput {ostream star}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-nkernel'! (WorksTestStatusDetector getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; add: #NOT.A.TYPE; yourself)! !WorksTestStatusDetector methodsFor: 'triggering'! {void} grabbed: work {FeWork} with: author {ID} with: reason {IntegerVar} [myOutput << myTag << ' canRevise (' << author << ') '] smalltalkOnly. '(*myOutput) << myTag << " canRevise (" << author << ")\n";' translateOnly.! {void} released: work {FeWork} with: reason {IntegerVar} [myOutput << myTag << ' released '] smalltalkOnly. '(*myOutput) << myTag << " released\n";' translateOnly! ! !WorksTestStatusDetector methodsFor: 'private: create'! create: oo {ostream reference} with: tag {Character star} super create. [myOutput := oo] smalltalkOnly. 'myOutput = &oo;' translateOnly. myTag := tag.! ! !WorksTestStatusDetector methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! WorksTestStatusDetector class instanceVariableNames: ''! (WorksTestStatusDetector getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; add: #NOT.A.TYPE; yourself)! !WorksTestStatusDetector class methodsFor: 'pseudo constructors'! {FeStatusDetector} make: oo {ostream reference} with: tag {Character star} ^self create: oo with: tag.! !FeDetector subclass: #FeWaitDetector instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-detect'! FeWaitDetector comment: 'Will get sent a single message, once, with no parameters, when something happens. It can be passed in to Server::waitForConsequences and Server::waitForWrite.BY.PROXY '! (FeWaitDetector getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; yourself)! !FeWaitDetector methodsFor: 'triggering'! {void CLIENT} done "Essential. Whatever I was waiting for has happened" self subclassResponsibility! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FeWaitDetector class instanceVariableNames: ''! (FeWaitDetector getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; yourself)! !FeWaitDetector class methodsFor: 'smalltalk: system'! info.stProtocol "{NOWAIT CLIENT} done "! !FeWaitDetector subclass: #CommWaitDetector instanceVariableNames: ' myManager {PromiseManager} myNumber {IntegerVar}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! CommWaitDetector comment: 'Send the detector events over comm.'! (CommWaitDetector getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !CommWaitDetector methodsFor: 'creation'! create: pm {PromiseManager} with: number {IntegerVar} super create. myManager _ pm. myNumber _ number! {void} destruct FeServer removeWaitDetector: self. super destruct! ! !CommWaitDetector methodsFor: 'triggering'! {void} done "Essential. Whatever I was waiting for has happened" myManager queueDetectorEvent: (DoneEvent make: myNumber)! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CommWaitDetector class instanceVariableNames: ''! (CommWaitDetector getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !CommWaitDetector class methodsFor: 'creation'! make: pm {PromiseManager} with: number {IntegerVar} ^self create: pm with: number! !FeWaitDetector subclass: #WorksWaitDetector instanceVariableNames: ' myTag {Character star} myOutput {ostream star}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-nkernel'! WorksWaitDetector comment: 'This class keeps a pointer to an ostream rather than a reference since class ios::operator=() is private.'! (WorksWaitDetector getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; add: #NOT.A.TYPE; yourself)! !WorksWaitDetector methodsFor: 'creation'! create: oo {ostream reference} with: tag {Character star} super create. [myOutput := oo] smalltalkOnly. 'myOutput = &oo;' translateOnly. myTag := tag.! ! !WorksWaitDetector methodsFor: 'triggering'! {NOACK CLIENT} done [myOutput << myTag << ' '] smalltalkOnly. '*myOutput << myTag << "\n";' translateOnly.! ! !WorksWaitDetector methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! WorksWaitDetector class instanceVariableNames: ''! (WorksWaitDetector getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; add: #NOT.A.TYPE; yourself)! !WorksWaitDetector class methodsFor: 'creation'! {FeWaitDetector} make: oo {ostream reference} with: tag {Character star} ^self create: oo with: tag! !Heaper subclass: #FeKeyMaster instanceVariableNames: ' myLoginAuthority {IDRegion} myActualAuthority {IDRegion} myRegisteredWorks {PrimSet | NULL of: FeWork}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-nkernel'! FeKeyMaster comment: 'A KeyMaster provides the authority, or "holds the keys", for a client`s activities on the BackEnd. A client can have any number of different KeyMasters, each with different authority. FeServer_login (if successful) gives you back a KeyMaster with the authority of a single Club (along with all the Clubs of which it is a member, directly or indirectly). This will give you appropriate authority to do anything permitted to that Club. You can incorporate the authority of other KeyMasters into it, so that it will additionally enable you to do anything the other KeyMasters would have enabled.'! (FeKeyMaster getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #ON.CLIENT; add: #EQ; yourself)! !FeKeyMaster methodsFor: 'authority'! {IDRegion CLIENT} actualAuthority "Essential. The Clubs whose authority is actually being held right now. This may change asynchronously when you or others change the membership lists of clubs. It is my loginAuthority plus all clubs that list any of these clubs as members, transitively." ^myActualAuthority! {FeKeyMaster CLIENT} copy "Essential. A different KeyMaster with the same login and actual authority as this one." ^FeKeyMaster make: myLoginAuthority with: myActualAuthority! {BooleanVar CLIENT} hasAuthority: clubID {ID} "Whether this KeyMaster is currently holding the authority of the given Club. Equivalent to this->actualAuthority ()->hasMember (clubID)" ^myActualAuthority hasMember: clubID! {void CLIENT} incorporate: other {FeKeyMaster} "Essential. Add the other KeyMaster's login and actual authorities to my own respective authorities." | newLogins {XnRegion} | newLogins := other loginAuthority minus: myLoginAuthority. myLoginAuthority := (myLoginAuthority unionWith: other loginAuthority) cast: IDRegion. myActualAuthority := (myActualAuthority unionWith: other actualAuthority) cast: IDRegion. "Tell all my Works" self authorityChanged. "Register with the new login Clubs to find out when their super clubs change" newLogins stepper forEach: [ :login {ID} | ((CurrentGrandMap fluidGet get: login) cast: BeClub) registerKeyMaster: self]! {IDRegion CLIENT} loginAuthority "Essential. The Clubs whose authority was obtained directly, by logging in to them. They are the ones from which all other authority is derived." ^myLoginAuthority! {void CLIENT} removeLogins: oldLogins {IDRegion} "Essential. Remove the listed IDs from the set of Clubs whose login authority I exercise. All authority derived from them that cannot be derived from the remaining login authority will also disappear. Listed Clubs for which I do not hold login authority will be silently ignored." | removed {IDRegion} | removed := (oldLogins intersect: myLoginAuthority) cast: IDRegion. myLoginAuthority := (myLoginAuthority minus: removed) cast: IDRegion. "Figure out the new transitive authority" self updateAuthority. "Unregister with the new IDs" removed stepper forEach: [ :login {ID} | ((CurrentGrandMap fluidGet get: login) cast: BeClub) unregisterKeyMaster: self]! ! !FeKeyMaster methodsFor: 'private: create'! create: loginAuthority {IDRegion} with: actualAuthority {IDRegion} super create. myLoginAuthority := loginAuthority. myActualAuthority := actualAuthority. myRegisteredWorks := NULL.! ! !FeKeyMaster methodsFor: 'server accessing'! {BooleanVar} hasSignatureAuthority: club {ID} "Whether this KeyMaster has signature authority for the given Club" | sig {ID} cgm {BeGrandMap} | cgm := CurrentGrandMap fluidGet. ^(sig := (cgm getClub: club) fetchSignatureClub) ~~ NULL and: [self hasAuthority: sig]! {void} registerWork: work {FeWork} "Notify the Work whenever my authority changes" myRegisteredWorks == NULL ifTrue: [myRegisteredWorks := PrimSet weak]. myRegisteredWorks introduce: work! {void} unregisterWork: work {FeWork} "Notify the Work whenever my authority changes" (myRegisteredWorks == NULL or: [myRegisteredWorks isEmpty]) ifTrue: [Heaper BLAST: #NeverAddedWatcher]. myRegisteredWorks remove: work. myRegisteredWorks isEmpty ifTrue: [myRegisteredWorks := NULL].! {void} updateAuthority "Recompute the actual authority of this KeyMaster based on the set of login Clubs" myActualAuthority := (IDSpace global emptyRegion cast: IDRegion). myLoginAuthority stepper forEach: [ :login {ID} | myActualAuthority := (myActualAuthority unionWith: ((CurrentGrandMap fluidGet get: login) cast: BeClub) transitiveSuperClubIDs) cast: IDRegion]. self authorityChanged.! ! !FeKeyMaster methodsFor: 'private:'! {void} authorityChanged "Notify all my dependents of a change in authority" myRegisteredWorks ~~ NULL ifTrue: [myRegisteredWorks stepper forEach: [ :work {FeWork} | work updateStatus]]! ! !FeKeyMaster methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << 'KeyMaster(' << self loginAuthority << ')'! ! !FeKeyMaster methodsFor: 'obsolete:'! {Filter} permissionsFilter "A filter for things which can be read by this KeyMaster" self thingToDo. "have all callers use 'actualAuthority' instead" ^CurrentGrandMap fluidGet globalIDFilterSpace anyFilter: myActualAuthority! ! !FeKeyMaster methodsFor: 'smalltalk: passe'! {void} removeAuthority: oldLogins {IDRegion} self passe. "renamed removeLogins:"! ! !FeKeyMaster methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FeKeyMaster class instanceVariableNames: ''! (FeKeyMaster getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #ON.CLIENT; add: #EQ; yourself)! !FeKeyMaster class methodsFor: 'creation'! make: clubID {ID} "Make a KeyMaster initially logged in to the given Club" ^self make: (clubID asRegion cast: IDRegion) "login authority" with: (CurrentGrandMap fluidGet getClub: clubID) transitiveSuperClubIDs! {FeKeyMaster} makeAll: clubIDs {IDRegion} "Make a KeyMaster initially logged in to the given Clubs" | actuals {IDRegion} gm {BeGrandMap} | gm := CurrentGrandMap fluidGet. actuals := gm globalIDSpace emptyRegion cast: IDRegion. clubIDs stepper forEach: [:iD {ID} | actuals := (actuals unionWith: (gm getClub: iD) transitiveSuperClubIDs) cast: IDRegion]. ^self make: clubIDs with: actuals! {FeKeyMaster} makePublic "Make a KeyMaster logged in to the Universal Public Club." ^FeKeyMaster make: FeServer publicClubID! ! !FeKeyMaster class methodsFor: 'private: pseudo constructors'! make: loginAuthority {IDRegion} with: actualAuthority {IDRegion} | result {FeKeyMaster} | result := self create: loginAuthority with: actualAuthority. "Register with all the login Clubs to find out when their permissions change" loginAuthority stepper forEach: [ :loginClubID {ID} | ((CurrentGrandMap fluidGet get: loginClubID) cast: BeClub) registerKeyMaster: result]. ^result! ! !FeKeyMaster class methodsFor: 'smalltalk: system'! info.stProtocol "{IDRegion CLIENT} actualAuthority {FeKeyMaster CLIENT} copy {BooleanVar CLIENT} hasAuthority: clubID {ID} {void CLIENT} incorporate: other {FeKeyMaster} {IDRegion CLIENT} loginAuthority {void CLIENT} removeLogins: oldLogins {IDRegion} "! ! !FeKeyMaster class methodsFor: 'assertions'! {void} assertAdminAuthority "Blast if the CurrentKeyMaster doesn't have Admin authority." (CurrentKeyMaster fluidGet hasAuthority: CurrentGrandMap fluidGet adminClubID) ifFalse: [Heaper BLAST: #MustHaveAdminAuthority].! {void} assertSignatureAuthority "Blast if the CurrentKeyMaster doesn't have signature authority for the CurrentAuthor." (CurrentKeyMaster fluidGet hasSignatureAuthority: CurrentAuthor fluidGet) ifFalse: [Heaper BLAST: #MustHaveAuthorSignatureAuthority].! {void} assertSponsorship "If there is a currentSponsor, then the CurrentKeyMaster must have authority for it." | ckm {FeKeyMaster} cgm {BeGrandMap} | ckm := CurrentKeyMaster fluidGet. cgm := CurrentGrandMap fluidGet. (InitialSponsor fluidGet == cgm emptyClubID or: [ckm hasAuthority: InitialSponsor fluidFetch]) ifFalse: [Heaper BLAST: #MustHaveSponsorAuthority]! !Heaper subclass: #FeRangeElement instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-nkernel'! FeRangeElement comment: 'The kinds of objects which can be in the range of Editions.'! (FeRangeElement getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; add: #EQ; yourself)! !FeRangeElement methodsFor: 'smalltalk: defaults'! {FeEdition CLIENT} works ^self works: NULL with: 0 with: NULL! {FeEdition CLIENT} works: filter {Filter default: NULL} ^self works: filter with: 0 with: NULL! {FeEdition CLIENT} works: filter {Filter default: NULL} with: flags {Int32 default: Int32Zero} ^self works: filter with: flags with: NULL! ! !FeRangeElement methodsFor: 'accessing'! {void} addFillDetector: detector {FeFillDetector} "Essential. When this PlaceHolder becomes any other kind of RangeElement, then the Detector will be triggered with the new RangeElement. If this is already not a PlaceHolder, then the Detector is triggered immediately with this RangeElement. See FillRangeDetector::filled (RangeElement * newIdentity)." detector filled: self. "default will be overridden in FePlaceHolder"! {FeRangeElement CLIENT} again "Essential. An object reflecting the current identity of this object, in case it is a PlaceHolder that has become something else since it was received from the Server." self subclassResponsibility! {BooleanVar CLIENT} canMakeIdentical: newIdentity {FeRangeElement} "Essential. Whether the identity of this object could be changed to the other. Does not check whether the CurrentKeyMaster has authority to do it. The restrictions on this operation depend on which subclass this is, but in general (except for PlaceHolders) an object can only become another of the same type with the same content." RaviNow shouldImplement. ^false "fodder"! {FeFillDetector CLIENT} fillDetector "Essential. Return a FillDetector that will be triggered when this RangeElement becomes something other than a PlaceHolder, or immeditely if this RangeElement is not currently a PlaceHolder. See FillRangeDetector::filled (RangeElement * newIdentity)." Dean shouldImplement. self addFillDetector: NULL. ^NULL "fodder"! {BooleanVar CLIENT} isIdentical: other {FeRangeElement} "Essential. Return whether two objects have the same identity on the Server. Note that this can change over time, if makeIdentical is used. However, for a given pair of FeRangeElements, it can only change from not being the same to being the same while you are holding onto them." other cast: FeVirtualDataHolder into: [ :vd | ^vd isIdentical: self] cast: FeVirtualPlaceHolder into: [ :vp | ^vp isIdentical: self] others: ["This should be OK, since virtual subclasses override this anyway" ^self getOrMakeBe isEqual: other getOrMakeBe]. ^false "fodder"! {void CLIENT} makeIdentical: newIdentity {FeRangeElement} "Essential. Change the identity of this object to the other. BLAST if unsuccessful. Requires authority of the current owner; if the operation is successful, the owner will appear to change to that of the other object. Also requires enough permission on newIdentity to determine, by comparing content, whether the operation would succeed. The restrictions on this operation depend on which subclass this is, but in general (except for PlaceHolders) an object can only become another of the same type with the same content." self subclassResponsibility! {ID CLIENT} owner "Essential. The Club which owns this RangeElement, and has the authority to make it become something else, and to transfer ownership to someone else." ^self getOrMakeBe owner "virtuals should override"! {void} removeFillDetector: detector {FeFillDetector} "Essential. Remove a Detector which had been added to this RangeElement. You should remove every Detector you add, although they will go away automatically when a client session terminates." || "Do nothing. PlaceHolder overrides"! {void CLIENT} setOwner: clubID {ID} "Essential. Change the owner; must have the authority of the current owner." (CurrentKeyMaster fluidGet hasAuthority: self owner) ifFalse: [Heaper BLAST: #MustBeOwner]. "Need to make it into a reified range element in order to have distinct ownership" CurrentGrandMap fluidGet getClub: clubID. "Checks that it is a club." self getOrMakeBe setOwner: clubID! {FeEdition CLIENT} transcluders: directFilter {Filter default: NULL} with: indirectFilter {Filter default: NULL} with: flags {Int32 default: Int32Zero} with: otherTranscluders {FeEdition default: NULL} "All Editions which the CurrentKeyMaster can see, which transclude this RangeElement. If a directFilter is given, then the visibleEndorsements on a Edition must match the filter. If an indirectFilter is given, then a resulting Edition must be contained in some readable Edition whose visibleEndorsements match the filter. If the directContainersOnly flag is set, then a resulting Edition must contain this directly as a RangeElement; otherwise, indirect containment through Editions is allowed. If the localPresentOnly flag is set, then only Editions currently known to this Server are guaranteed to end up in the result; otherwise, Editions which come to satisfy the conditions in the future, and those on other Servers, may also be found. Equivalent to FeServer::current ()->newEditionWith (, this) ->rangeTranscluders (NULL, directFilter, indirectFilter, flags, otherTranscluders)." ^(FeEdition fromOne: IntegerVarZero integer with: self) rangeTranscluders: NULL with: directFilter with: indirectFilter with: flags with: otherTranscluders! {FeEdition CLIENT} works: filter {Filter default: NULL} with: flags {Int32 default: Int32Zero} with: otherTranscluders {FeEdition default: NULL} "Essential. Works which contain this RangeElement and can be read by the CurrentKeyMaster. Returns an IDSpace Edition full of PlaceHolders, which will be filled with Works as results come in. If a filter is given, then only Works whose endorsements pass the Filter are returned. If localPresentOnly flag is set, then only Works currently known to this Server are returned; otherwise, as new Works come to be known to the Server, they are filled into the resulting Edition. If directContainersOnly is set, and this is an Edition, then only Works which are directly on this Edition are returned (and not Works which are on Editions which have this one as sub-Editions). { | w's contains self, w passes filter}" | theFilter {Filter} | filter == NULL ifTrue: [theFilter := CurrentGrandMap fluidGet endorsementFilterSpace fullRegion cast: Filter] ifFalse: [theFilter := filter]. Dean thingToDo. "avoid reifying" ^FeEdition on: (self getOrMakeBe works: CurrentKeyMaster fluidGet actualAuthority with: theFilter with: flags)! ! !FeRangeElement methodsFor: 'server accessing'! {BeCarrier} carrier "Return an object that wraps up any run-time state that might be needed inside the Be system. Right now that means labels." ^BeCarrier make: self getOrMakeBe! {BeRangeElement | NULL} fetchBe "If this has a reified Be object, then return it, else NULL" self subclassResponsibility! {BeRangeElement} getOrMakeBe "An individual BeRangeElement for this identity. If the object is virtualized, then de-virtualizes it." self subclassResponsibility! ! !FeRangeElement methodsFor: 'smalltalk:'! inspect "Sensor leftShiftDown" true ifTrue: [self basicInspect] ifFalse: [EntView openOn: (TreeBarnacle new buildOn: self gettingChildren: [:elem | (elem respondsTo: #inspectPieces) ifTrue: [elem inspectPieces] ifFalse: [#()]] gettingImage: [:me | DisplayText text: me displayString asText textStyle: (TextStyle styleNamed: #small)] at: 0 @ 0 vertical: true separation: 5 @ 10)]! {FeEdition CLIENT} transcluders ^self transcluders: NULL with: NULL with: Int32Zero with: NULL! {FeEdition CLIENT} transcluders: directFilter {Filter default: NULL} ^self transcluders: directFilter with: NULL with: Int32Zero with: NULL! {FeEdition CLIENT} transcluders: directFilter {Filter default: NULL} with: indirectFilter {Filter default: NULL} ^self transcluders: directFilter with: indirectFilter with: Int32Zero with: NULL! {FeEdition CLIENT} transcluders: directFilter {Filter default: NULL} with: indirectFilter {Filter default: NULL} with: flags {Int32 default: Int32Zero} ^self transcluders: directFilter with: indirectFilter with: flags with: NULL! ! !FeRangeElement methodsFor: 'labelling'! {FeLabel CLIENT} label "Essential. Return the label attached to this FeRangeElement. (An FeRangeElement holds a BeRangeElement and a label.) All FeRangeElements have a label attached to them when they are created (in the various Server::newRangeElement operations). Derived Editions have the same the label as the Edition they were derived from (e.g. the receiver of copy, combine, replace, transformedBy, etc.) Labels may be available only on Editions in 1.0. (While this is in force, label() will blast if sent to other kinds of FeEditions.)" self unimplemented. "default" ^NULL! {FeRangeElement CLIENT} relabelled: label {FeLabel} "Essential. Return a new FeRangeElement with the same identity and contents (i.e. holding the same BeRangeElement), but with a different label. (Get new labels from FeServer::newLabel())" self unimplemented. "default" ^NULL! ! !FeRangeElement methodsFor: 'smalltalk: passe'! {BooleanVar} becomeOther: newIdentity {FeRangeElement} self passe. "renamed makeIdentical:"! {BooleanVar} isSameAs: other {FeRangeElement} self passe "isIdentical"! ! !FeRangeElement methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FeRangeElement class instanceVariableNames: ''! (FeRangeElement getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; add: #EQ; yourself)! !FeRangeElement class methodsFor: 'protected:'! {void} validateEndorsement: endorsements {CrossRegion} with: km {FeKeyMaster} "Check whether the endorsements are valid and authorized. Blast appropriately if not." endorsements isFinite ifFalse: [Heaper BLAST: #EndorsementMustBeFinite]. self validateSignature: ((endorsements projection: Int32Zero) cast: IDRegion) with: km! {void} validateSignature: clubs {IDRegion} with: km {FeKeyMaster} "Check whether the signatures are valid and authorized. Blast appropriately if not." clubs isFinite ifFalse: [Heaper BLAST: #MustHaveSignatureAuthority]. clubs stepper forEach: [ :clubID {ID} | (km hasSignatureAuthority: clubID) ifFalse: [Heaper BLAST: #MustHaveSignatureAuthority]]! ! !FeRangeElement class methodsFor: 'smalltalk: system'! info.stProtocol "{void CLIENT} addFillDetector: detector {PrFillDetector} {FeRangeElement CLIENT} again {BooleanVar CLIENT} canMakeIdentical: newIdentity {FeRangeElement} {BooleanVar CLIENT} isIdentical: other {FeRangeElement} {FeLabel CLIENT} label {void CLIENT} makeIdentical: newIdentity {FeRangeElement} {ID CLIENT} owner {FeRangeElement CLIENT} relabelled: label {FeLabel} {void CLIENT} removeFillDetector: detector {PrFillDetector} {void CLIENT} setOwner: clubID {ID} {FeEdition CLIENT} transcluders {FeEdition CLIENT} transcluders: directFilter {Filter default: NULL} {FeEdition CLIENT} transcluders: directFilter {Filter default: NULL} with: indirectFilter {Filter default: NULL} {FeEdition CLIENT} transcluders: directFilter {Filter default: NULL} with: indirectFilter {Filter default: NULL} with: flags {Int32 default: Int32Zero} {FeEdition CLIENT} transcluders: directFilter {Filter default: NULL} with: indirectFilter {Filter default: NULL} with: flags {Int32 default: Int32Zero} with: otherTrail {FeEdition default: NULL} {FeEdition CLIENT} works: filter {Filter default: NULL} with: flags {Int32 default: Int32Zero} with: otherTrail {FeEdition default: NULL} "! ! !FeRangeElement class methodsFor: 'creation'! {FeRangeElement CLIENT} placeHolder "Make a single PlaceHolder." ^FePlaceHolder on: CurrentGrandMap fluidGet newPlaceHolder! !FeRangeElement subclass: #FeDataHolder instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-nkernel'! FeDataHolder comment: 'The kind of FeRangeElement that represents a piece of data in the Server, along with its identity.'! (FeDataHolder getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; yourself)! !FeDataHolder methodsFor: 'client accessing'! {FeRangeElement} again self subclassResponsibility! {BooleanVar} canMakeIdentical: newIdentity {FeRangeElement} "Check that it is data with the same value, and check permissions, and forward the operation after coercing the newIdentity to a persistent RangeElement." ^((newIdentity isKindOf: FeDataHolder) and: [((newIdentity cast: FeDataHolder) value isEqual: self value)])! {void} makeIdentical: newIdentity {FeRangeElement} "Allow consolidation of data in 1st product." | ckm {FeKeyMaster} | "Check that it is data with the same value, and check permissions, and forward the operation after coercing the newIdentity to a persistent RangeElement." self thingToDo. "better blast" ckm := CurrentKeyMaster fluidGet. ((newIdentity isKindOf: FeDataHolder) and: [((newIdentity cast: FeDataHolder) value isEqual: self value) and: [ckm hasAuthority: self owner]]) ifTrue: [Heaper BLAST: #CantMakeIdentical]. self getOrMakeBe makeIdentical: newIdentity getOrMakeBe! {PrimValue CLIENT} value "Essential. The actual data value" self subclassResponsibility! ! !FeDataHolder methodsFor: 'server accessing'! {BeRangeElement | NULL} fetchBe self subclassResponsibility! {BeRangeElement} getOrMakeBe self subclassResponsibility! ! !FeDataHolder methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << 'DataHolder(' << self value << ')'! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FeDataHolder class instanceVariableNames: ''! (FeDataHolder getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; yourself)! !FeDataHolder class methodsFor: 'creation'! {FeDataHolder} fake: value {PrimValue} with: key {Position} with: edition {BeEdition} ^FeVirtualDataHolder create: value with: key with: edition.! {FeDataHolder CLIENT} make: value {PrimValue} "Make a single DataHolder with the given value" ^FeDataHolder on: (CurrentGrandMap fluidGet newDataHolder: value)! {FeDataHolder} on: be {BeDataHolder} | result {FeDataHolder} | result := FeActualDataHolder create: be. be addFeRangeElement: result. ^result! ! !FeDataHolder class methodsFor: 'smalltalk: system'! info.stProtocol "{PrimValue CLIENT} value "! !FeDataHolder subclass: #FeActualDataHolder instanceVariableNames: 'myBeDataHolder {BeDataHolder}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-nkernel'! FeActualDataHolder comment: 'Actually has a persistent individual DataHolder on the Server'! (FeActualDataHolder getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !FeActualDataHolder methodsFor: 'client accessing'! {FeRangeElement} again "I'm completely reified. Just return me." ^self! {PrimValue} value "The actual data value" ^myBeDataHolder value! ! !FeActualDataHolder methodsFor: 'server accessing'! {BeRangeElement | NULL} fetchBe ^myBeDataHolder! {BeRangeElement} getOrMakeBe ^myBeDataHolder! ! !FeActualDataHolder methodsFor: 'private: create'! create: be {BeDataHolder} super create. myBeDataHolder := be.! ! !FeActualDataHolder methodsFor: 'destruct'! {void} destruct myBeDataHolder removeFeRangeElement: self. super destruct.! !FeDataHolder subclass: #FeVirtualDataHolder instanceVariableNames: ' myValue {PrimValue} myKey {Position} myEdition {BeEdition}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-nkernel'! FeVirtualDataHolder comment: 'Fakes a DataHolder by having an Edition and a key.'! (FeVirtualDataHolder getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !FeVirtualDataHolder methodsFor: 'accessing'! {FeRangeElement} again "Fetch from my Edition again, just in case I've been consolidated." ^myEdition fetch: myKey! {BooleanVar} isIdentical: other {FeRangeElement} "This can do a version comparison (which seems a bit extreme)." Dean shouldImplement. ^false "fodder"! {ID} owner ^myEdition ownerAt: myKey! {PrimValue} value ^myValue! ! !FeVirtualDataHolder methodsFor: 'server accessing'! {BeRangeElement | NULL} fetchBe ^NULL! {BeRangeElement} getOrMakeBe "Force the ent to generate a beRangeElement at myKey." ^myEdition getOrMakeBe: myKey! ! !FeVirtualDataHolder methodsFor: 'private: create'! create: value {PrimValue} with: key {Position} with: edition {BeEdition} super create. myValue := value. myKey := key. myEdition := edition.! !FeRangeElement subclass: #FeEdition instanceVariableNames: ' myBeEdition {BeEdition} myLabel {FeLabel}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-nkernel'! FeEdition comment: 'The kind of FeRangeElement that consists of an immutable organization of RangeElements, indexed by Positions in some CoordinateSpace. R1 prohibits cyclic containment. Set notation is used in the comments documenting some of the methods of this class. In each case the cleartext explanation stands alone, and the set notation is a separate, more formal, expression of the actions of the method, in terms of key(position)/label/value triples ("").'! (FeEdition getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !FeEdition methodsFor: 'operations'! {FeEdition CLIENT} combine: other {FeEdition} "Essential. Return a new FeEdition containing the contents of boththe receiver and the argument Editions, and with the label of the receiving edition; where they share positions, they must have the same RangeElement. Currently the two may not share positions. It is unclear whether to elevate this from an implementation restriction to a specification. The advantage of so specifying is that 'combine' becomes timing independent, i.e. a failing combine could otherwise succeed after the differing range elements were unified (by FeRangeElement::makeIdentical()). See FeEdition::mapSharedOnto and FeEdition::transformedBy. { | in self or in other } requires: currently: { k | in self and in other } is empty eventually maybe: { k | v1 not same as v2 and in self and in other } is empty" ^FeEdition on: (myBeEdition combine: other beEdition) with: myLabel! {FeEdition CLIENT} copy: positions {XnRegion} "Return a new FeEdition which is the subset of this Edition with the domain restricted to the given set of positions The new edition has the same label as this edition. { | k in positions and in self }" ^FeEdition on: (myBeEdition copy: positions) with: myLabel! {FeEdition CLIENT} replace: other {FeEdition} "Return a new FeEdition with the label of the current Edition and the contents of both Editions; where they share positions, use the contents and labels of the other Edition. Equivalent to this->copy (other->domain ()->complement ())->combine (other). { | in other or ( in self and not in other }" ^FeEdition on: (myBeEdition replace: other beEdition) with: myLabel! {FeEdition CLIENT} transformedBy: mapping {Mapping} "Essential. Return a new FeEdition containing the contents and label of the current Edition with the positions transformed according to the given Mapping. Where the Mapping takes several positions in the domain to a single position in the range, this Edition must have the same RangeElement and label at all the domain positions. Currently the mapping must be 'onto', i.e., no more that one domain position may map onto any given range position. It is unclear whether to elevate this from an implementation restriction to a specification. See FeEdition::mapSharedOnto and FeEdition::combine. { | in self and in mapping } requires: Currently: not exists k1a, k1b : k1a !!= k1b and in mapping and in mapping. Maybe eventually: for all v1, v2 : in result and in result, v1 is same as v2" ^FeEdition on: (myBeEdition transformedBy: mapping) with: myLabel! {FeEdition CLIENT} with: position {Position} with: value {FeRangeElement} "Return a new FeEditionwith the same contents and label as this Edition, except for the addition or substitution of a RangeElement at a specified position. (The difference between with() and rebind() is exactly that rebind() preserves the old label at position, while with() installs the label attached to the value argument.) Equivalent to: this->replace (FeServer::current ()->makeEditionWith (position, value))" ^FeEdition on: (myBeEdition with: position with: value carrier) with: myLabel! {FeEdition CLIENT} withAll: positions {XnRegion} with: value {FeRangeElement} "Return a new FeEdition with the same contents and label as this Edition, except at a specified set of positions, where the old values and labels, if there are any, are superceded by the value argument. Equivalent to: this->replace (FeServer::current ()->makeEditionWithAll (positions, value))" ^FeEdition on: (myBeEdition withAll: positions with: value carrier) with: myLabel! {FeEdition CLIENT} without: position {Position} "Return a new FeEdition with the same contents and label as this Edition, except at a specified position, where the old value and label, if there is one, is removed. Equivalent to: this->copy (position->asRegion ()->complement ())" ^FeEdition on: (myBeEdition without: position) with: myLabel! {FeEdition CLIENT} withoutAll: positions {XnRegion} "Return a new FeEdition with the same contents and label as this Edition, except at a specified set of positions, where the old values and labels, if there are any, are removed. Equivalent to this->copy (positions->complement ())" ^FeEdition on: (myBeEdition withoutAll: positions) with: myLabel! ! !FeEdition methodsFor: 'accessing'! {CoordinateSpace CLIENT} coordinateSpace "Return the space in which the positions of this Edition are positions. Equivalent to this->domain ()->coordinateSpace ()" ^myBeEdition coordinateSpace! {IntegerVar CLIENT} cost: method {Int32} "Essential. Retiurn how much space this Edition is taking up on the disk, in bytes (but the precision may exceed the accuracy; it's simply a well-known unit). The method determines how material shared with other Editions is treated: if omitShared, it is not counted at all; if prorateShared, then it is divided evenly among the Editions sharing it; if totalShared, its entire cost is counted. This figure is only approximate, and may vary with time. (No permissions are required to obtain this informiation, even though it exposes sharing by Editions you can't read to traffic analysis.)" Someone shouldImplement. ^IntegerVarZero "fodder"! {IntegerVar CLIENT} count "Return the number of positions in this Edition. Blasts if infinite. Equivalent to this->domain ()->count ()" ^myBeEdition count! {XnRegion CLIENT} domain "Essential. Return the region consisting of all the positions in this Edition. May be infinite, or empty. { k | in self }" ^myBeEdition domain! {FeRangeElement CLIENT} get: position {Position} "Return the value at the given position, or blast if there is no such position (i.e. if !! this->domain ()->hasMember (position)). v : in self requires: in self" ^myBeEdition get: position! {BooleanVar CLIENT} hasPosition: position {Position} "Return whether the given position is in the Edition. Equivalent to this->domain ()->hasMember (position)" self thingToDo. "rename Be protocol" ^myBeEdition includesKey: position! {BooleanVar CLIENT} isEmpty "Return whether there are any positions in this Edition. Equivalent to this->domain ()->isEmpty ()" ^myBeEdition isEmpty! {BooleanVar CLIENT} isFinite "Return whether there are a finite number of positions in this Edition. Equivalent to this->domain ()->isFinite ()" ^myBeEdition isFinite! {(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 a region is given, only that subset of the Edition's contents will be returned. If it is not given, the entire content of the Edition will be returned. if the ignoreTotalOrdering flag is set, then the operation can group non-contiguous regions, and can supply the bundles in any order. if the ignoreArrayOrdering flag is set, then ArrayBundles returned by the operation can be ordered differently from the supplied order. If an OrderSpec is not supplied, then the ordering will be the default order for the coordinate space, if one exists, and if none exists the returned data will be completely unordered and the Ordering flags will be ignored." self thingToDo. "The above comment is still horribly insufficient." ^myBeEdition retrieve: region with: order with: flags! {TableStepper CLIENT of: FeRangeElement} stepper: region {XnRegion default: NULL} with: ordering {OrderSpec default: NULL} "Return a stepper for iterating over the positions and RangeElements of this Edition. If a region is specified, then it only iterates over the domain positions which are in the given region. If no ordering is specified, then the default ascending full ordering of the CoordinateSpace is used, or a random order chosen if there is no default." | theRegion {XnRegion} | theRegion := self domain. region ~~ NULL ifTrue: [theRegion := theRegion intersect: region]. ^EditionStepper create: (theRegion stepper: ordering) with: self! {FeRangeElement CLIENT} theOne "If this Edition has a single position, then return the RangeElement at that position; if not, blasts. Equivalent to this->get (this->domain ()->theOne ())" ^myBeEdition theOne! ! !FeEdition methodsFor: 'comparing'! {BooleanVar CLIENT} isRangeIdentical: other {FeEdition} with: region {XnRegion default: NULL} "Whether the two Editions have the same domains, and each RangeElement isIdentical to the corresponding RangeElement in the other Edition." Someone shouldImplement. ^false "fodder"! {Mapping CLIENT} mapSharedOnto: other {FeEdition} "Return a mapping such that for each range element that appears in both editions, the mapping maps each of its appearances in the argument edition to some appearance in this one. (Some of the appearances in this edition may be unmapped or mapped to multiple appearances in the argument edition.) Like 'mapSharedTo' except that the resulting mapping is 'onto'. This means that each range position of the resulting mapping inverse maps to at most one domain position. Such a mapping is suitable as an argument to 'transformedBy', and represents the minimal transformation needed to make the shared part of 'other' from self. Note that there is no unique answer. result = { | in self and in other and v1 is same as v2 and not exists k11 : k11 !!= k1 and in result } Note that this is useful for optimization of FeBe communication and Frontend display updating." Someone shouldImplement. ^NULL "fodder"! {Mapping CLIENT} mapSharedTo: other {FeEdition} "Essential. Return a Mapping from each of the positions in this Edition to all of the positions in the other Edition which have the same RangeElement. { | in self and in other and v1 is same as v2 }" ^myBeEdition mapSharedTo: other beEdition! {FeEdition CLIENT} notSharedWith: other {FeEdition} with: flags {Int32 default: Int32Zero} "Return a new FeEdition containing exactly the subset of this Edition whose RangeElements are not in the other Edition. Equivalent to: this->copy (this->sharedRegion (other)->complement ()). { | in self and in other and v1 is same as v2 } Note that this is useful for optimization of FeBe communication and Frontend display updating." ^FeEdition on: (myBeEdition notSharedWith: other beEdition with: flags) with: myLabel! {XnRegion CLIENT} positionsOf: value {FeRangeElement} "Return the region consisting of all the positions in this Edition at which the given RangeElement can be found. Equivalent to: this->sharedRegion (theServer ()->makeEditionWith (some position, value)). { k | in self and v is same as value }" self thingToDo. "rename Be protocol" ^myBeEdition keysOf: value! {FeEdition CLIENT} rangeTranscluders: positions {XnRegion default: NULL} with: directFilter {Filter default: NULL} with: indirectFilter {Filter default: NULL} with: flags {Int32 default: Int32Zero} with: otherTranscluders {FeEdition default: NULL} "Essential. Return a new FeEdition containing all Editions which can be read with the authority of the CurrentKeyMaster, and which transclude RangeElements in this Edition. Immediately returns with an Edition full of PlaceHolders, which will be filled in as results appear; the lookup proceeds asynchronously. The Server will attempt to avoid placing duplicate copies in the result, but it may still happen. If a Region is given, then the request only considers the subset at those positions (i.e. equivalent to this->copy (positions)->rangeTransclusions (...)) If a directFilter is given, then the endorsements on the resulting Editions, unioned with the endorsements on any Works directly on those Editions to which the CurrentKeyMaster has read permission, must pass the filter. If an indirectFilter is given, then the resulting Editions must be contained, directly or indirectly, by an Edition whose endorsements (unioned with its readable Works endorsements) pass the filter. (Giving a non-NULL indirectFilter will probably not be supported in version 1.0.) If the directContainersOnly flag is set, then the result only includes Editions which have the material as RangeElements; otherwise, the result includes Editions which indirectly contain the material through other Editions. (Setting this flag will probably not be supported in version 1.0.) If the fromTransitiveContents flag is set, then the result includes transclusions of RangeElements of sub-Editions of this one, in addition to the RangeElements in this Edition. (Setting ths flag will probably not be supported in version 1.0.) If localPresentOnly flag is clear, a persistent request will be created, and the new FeEdition will continue to be filled in in the future. If it is set, only those Editions which are currently known to transclude by this Backend are sure to be recorded into the Trail. (Some, but not all, Editions which come to transclude while this request is being processed may be recorded. If the request is followed by a FeServer::waitForConsequences(), no Editions which come to transclude after the wait completes will be recorded.) If otherTranscluders is given, then the results will be recorded into it. (This may increase the chance of the same Edition being recorded twice.) (For convenience, you can attach a TransclusionDetector to the result Edition. See FeEdition::addFillRangeDetector() See also FeServer::waitForConsequences().)" | theOther {BeEdition} theDirectFilter {Filter} theIndirectFilter {Filter} | otherTranscluders == NULL ifTrue: [theOther := NULL] ifFalse: [theOther := otherTranscluders beEdition]. directFilter == NULL ifTrue: [theDirectFilter := FeServer endorsementFilterSpace fullRegion cast: Filter] ifFalse: [theDirectFilter := directFilter]. indirectFilter == NULL ifTrue: [theIndirectFilter := FeServer endorsementFilterSpace fullRegion cast: Filter] ifFalse: [theIndirectFilter := indirectFilter]. ^FeEdition on: (myBeEdition rangeTranscluders: positions with: theDirectFilter with: theIndirectFilter with: flags with: theOther)! {FeEdition CLIENT} rangeWorks: positions {XnRegion default: NULL} with: filter {Filter default: NULL} with: flags {Int32 default: Int32Zero} with: otherTranscluders {FeEdition default: NULL} "Essential. Return a new FeEdition containing all Works which contain RangeElements of this Edition and can be read by the CurrentKeyMaster. Returns an IDSpace Edition full of PlaceHolders, which will be filled with Works as results come in. If a filter is given, then only Works whose endorsements pass the Filter are returned. If the localPresentOnly flag is clear, a persistent request will be created, and as new Works come to be known to the Server, they will be filled into the resulting Edition. If it is set, only Works currently known to this Server are sure to be recorded into the Trail. (Some, but not all, Works which become known while this request is being processed may be recorded. If the request is followed by a FeServer::waitForConsequences(), no Works which become known after the wait completes will be recorded.) If the fromTransitiveContents flag is set, then the result includes Works which contain RangeElements transitively contained in this Edition. (This may not be supported in 1.0) If directContainersOnly is set, then only Works which are directly on Editions which are RangeElements of this Edition are returned (and not Works which are on Editions which have them as sub-Editions). If otherTranscluders is given, this records works into that trail. (For convenience, you can attach a TransclusionDetector to the result Edition. See FeEdition::addFillRangeDetector() See also FeServer::waitForConsequences().) { | w's contains self, w passes filter}" | theOther {BeEdition} theFilter {Filter} | otherTranscluders == NULL ifTrue: [theOther := NULL] ifFalse: [theOther := otherTranscluders beEdition]. filter == NULL ifTrue: [theFilter := FeServer endorsementFilterSpace fullRegion cast: Filter] ifFalse: [theFilter := filter]. ^FeEdition on: (myBeEdition rangeWorks: positions with: theFilter with: flags with: theOther)! {XnRegion CLIENT} sharedRegion: other {FeEdition} with: flags {Int32 default: Int32Zero} "Return the subset of the positions of this Edition which have RangeElements that are in the other Edition. If nestThis flag is set, then returns not only positions of RangeElements which are in the other, but also positions of Editions which have RangeElements which are in the other, or which have other such Editions, recursively. (This searches down to, but not across, work boundaries.) If nestOther flag is set, 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). If both flags are false, then equivalent to: this->mapSharedTo (other)->domain () { k1 | in self and in other and v1 is same as v2 }" ^myBeEdition sharedRegion: other beEdition with: flags! {FeEdition CLIENT} sharedWith: other {FeEdition} with: flags {Int32 default: Int32Zero} "Essential. Return a new FeEdition consisting of the subset of this Edition whose RangeElements are in the other Edition. If the same RangeElement is in this Edition at several different positions, all positions will be in the result (provided the RangeElement is also in the other Edition). Equivalent to: this->copy (this->sharedRegion (other, flags)). { | in self and in other and v1 is same as v2 }" ^FeEdition on: (myBeEdition sharedWith: other beEdition with: flags) with: myLabel! ! !FeEdition methodsFor: 'endorsing'! {void CLIENT} endorse: additionalEndorsements {CrossRegion} "Essential. Adds to the endorsements on this Edition. The region of additionalEndorsements must consist of a finite number of (club ID, token ID) pairs. CurrentKeyMaster must hold the signature authority of all the Clubs used to endorse; the request will blast and do nothing if any of the required authority is lacking. (Redoing an endorse() undoes a retract())" FeRangeElement validateEndorsement: additionalEndorsements with: CurrentKeyMaster fluidGet. myBeEdition endorse: additionalEndorsements! {CrossRegion CLIENT} endorsements "Essential. Return all of the endorsements which have been placed on this Edition and not retracted." ^myBeEdition endorsements! {void CLIENT} retract: endorsements {CrossRegion} "Essential. Removes endorsements from this Edition. This requires that the CurrentKeyMaster hold signature authority for all of the Clubs whose endorsements are in the list; will blast and do nothing if any of the required authority is lacking, even if the endorsements weren't there to be retracted. Ignores all endorsements which you could have removed, but which don't happen to be there right now. In the current release removed endorsements aren't preserved, so they vanish forever. Beginning in some future release removed endorsements will become inactive, but it will be possible to detect that they once had been present. The intent is for a removed endorsement to be analogous to a signature that has been struck out. You can express that you changed your mind, but you can't undo the past." FeRangeElement validateEndorsement: endorsements with: CurrentKeyMaster fluidGet. myBeEdition retract: endorsements! {CrossRegion CLIENT} visibleEndorsements "Essential. Return all the unretracted endorsements on this Edition along with those on any Works directly on it which the CurrentKeyMaster has permission to read." ^myBeEdition visibleEndorsements! ! !FeEdition methodsFor: 'becoming'! {void} addFillRangeDetector: detector {FeFillRangeDetector} "Essential. Connect a FillRangeDetector to the underlying BeEdition so that when any of the PlaceHolders in that Edition become any other kind of RangeElement, then the Detector will be triggered with an Edition containing the new RangeElements (but not necessarily at the same positions, or even in the same CoordinateSpace). If there already are non-PlaceHolders, then the Detector is triggered immediately with those RangeElements. See FillRangeDetector::allFilled (Edition * newIdentities)." myBeEdition addDetector: detector! {XnRegion CLIENT} canMakeRangeIdentical: newIdentities {FeEdition} with: positions {XnRegion default: NULL} "Essential. Return the region consisting of all locations at which my RangeElements can NOT be made identical to the corresponding RangeElements in the other Edition. (This seems like the opposite of what you want, but in fact it makes it easy to check for success.) Does not check whether you have permissions to do so, just whether it could be done by someone with the appropriate permissions. See rangeOwners." Dean shouldImplement. ^NULL "fodder"! {FeFillRangeDetector CLIENT} fillRangeDetector "Essential. Return a FillRangeDetector so that when any of the PlaceHolders in this Edition become any other kind of RangeElement, then the Detector will be triggered with an Edition containing the new RangeElements (but not necessarily at the same positions, or even in the same CoordinateSpace). If there already are non-PlaceHolders, then the Detector is triggered immediately with those RangeElements. See FillRangeDetector::allFilled (Edition * newIdentities)." Dean shouldImplement. self addFillRangeDetector: NULL. ^NULL "fodder"! {FeEdition CLIENT} makeRangeIdentical: newIdentities {FeEdition} with: positions {XnRegion default: NULL} "Essential. Try to change the identity of each RangeElements of this Edition which are in the Region (or all if no Region supplied) to that of the RangeElement at the same position in the other Edition. Returns the subset of this Edition which did not end up with the new identities, because of - lack of ownership authority - different contents - contents of other edition unreadable - incompatible types - no corresponding new identity Note that the labels on the RangeElements need not match and will NOT be changed." | never {BeEdition} maybe {BeEdition} trial {BeEdition} result {Pair of: BeEdition} theRegion {XnRegion} | "Keep trying the primitive routine until it says it can't do any more" self knownBug. "put loop into server loop" (self coordinateSpace isEqual: newIdentities coordinateSpace) ifFalse: [^self]. never := CurrentGrandMap fluidGet newEmptyEdition: self coordinateSpace. maybe := myBeEdition. theRegion := maybe domain. positions ~~ NULL ifTrue: [theRegion := theRegion intersect: positions]. trial := newIdentities beEdition copy: theRegion. [(result := maybe tryAllBecome: trial) fetchRight ~~ NULL] whileTrue: [never := never combine: (result left cast: BeEdition). maybe := result right cast: BeEdition. trial := trial copy: maybe domain]. ^FeEdition on: never with: myLabel! {IDRegion CLIENT} 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." ^myBeEdition rangeOwners: positions! {void} removeFillRangeDetector: detector {FeFillRangeDetector} "Essential. Remove a Detector which had been added to this Edition. You should remove every Detector you add, although they will go away automatically when a client session terminates." (Heaper isDestructed: myBeEdition) ifFalse: [myBeEdition removeDetector: detector]! {FeEdition CLIENT} setRangeOwners: newOwner {ID} with: region {XnRegion default: NULL} "Changes the owner of all RangeElements in the Edition (but not the Edition itself!!); requires the authority of the current owner of each range element. If a Region is supplied, then only sets those in the region. Returns the subset of this Edition which is in the Region whose owners did not end up being the new Owner because of lack of authority." | theRegion {XnRegion} | region == NULL ifTrue: [theRegion := self domain] ifFalse: [theRegion := region]. ^FeEdition on: (myBeEdition setRangeOwners: newOwner with: theRegion) with: myLabel! ! !FeEdition methodsFor: 'labelling'! {FeLabel} label ^myLabel! {XnRegion CLIENT} positionsLabelled: label {FeLabel} "Return a region consisting of exactly the positions in this Edition which are associated with the given label. { k | in self }" self thingToDo. "rename Be protocol" ^myBeEdition keysLabelled: (label fetchBe cast: BeLabel)! {FeEdition CLIENT} rebind: position {Position} with: edition {FeEdition} "Return a new FeEdition which is a copy of this Edition with the contained Edition at the given position replaced by the given Edition, but with the Label at that position unchanged. Equivalent to this->with (position, edition->relabelled (this->get (position)->label ())). Note that rebind() is useless (and blasts) when a non-edition RangeElement is at the given position. { | ((k isEqual: position) and (v is same as edition)) or ( in self and k !!= position) }" ^self class fromOne: position with: (edition relabelled: ((self get: position) cast: FeEdition) label)! {FeRangeElement} relabelled: label {FeLabel} ^FeEdition on: myBeEdition with: label! ! !FeEdition methodsFor: 'server accessing'! {BeEdition} beEdition ^myBeEdition! {BeCarrier} carrier "Return an object that wraps up any run-time state that might be needed inside the Be system. Right now that means labels." ^BeCarrier make: (myLabel getOrMakeBe cast: BeLabel) with: myBeEdition! {FeRangeElement} fetch: position {Position} "The value at the position, or NULL if there is none" ^myBeEdition fetch: position! {BeRangeElement | NULL} fetchBe ^myBeEdition! {BeRangeElement} getOrMakeBe ^myBeEdition! ! !FeEdition methodsFor: 'client implementation'! {FeRangeElement} again "These don't change as long as someone has a handle on them." ^self! {BooleanVar} canMakeIdentical: newIdentity {FeRangeElement} (self isIdentical: newIdentity) ifFalse: [self unimplemented]. ^true! {void} makeIdentical: newIdentity {FeRangeElement} (self isIdentical: newIdentity) ifFalse: [self unimplemented]! ! !FeEdition methodsFor: 'private: create'! create: beEdition {BeEdition} with: label {FeLabel} super create. myBeEdition := beEdition. myLabel _ label.! ! !FeEdition methodsFor: 'printing'! {void} printOn: oo {ostream reference} | before {char star} | self isEmpty ifTrue: [oo << 'Edition()'. ^VOID]. before := 'Edition('. (self retrieve: NULL with: NULL with: FeEdition IGNORE.U.TOTAL.U.ORDERING) forEach: [ :bundle {FeBundle} | oo << before << bundle region << ' -> '. bundle cast: FeArrayBundle into: [ :array | oo << array array] cast: FeElementBundle into: [ :range | oo << range element] cast: FePlaceHolderBundle into: [ :place | oo << '{...}']. before := ', ']. oo << ')'! ! !FeEdition methodsFor: 'smalltalk: defaults'! {XnRegion CLIENT} canMakeRangeIdentical: newIdentities {FeEdition} ^self canMakeRangeIdentical: newIdentities with: NULL! {BooleanVar CLIENT} isRangeIdentical: other {FeEdition} ^self isRangeIdentical: other with: NULL! {FeEdition CLIENT} makeRangeIdentical: newIdentities {FeEdition} ^self makeRangeIdentical: newIdentities with: NULL! {FeEdition CLIENT} notSharedWith: other {FeEdition} ^self notSharedWith: other with: 0! {FeEdition CLIENT} rangeTranscluders ^self rangeTranscluders: NULL with: NULL with: NULL with: Int32Zero with: NULL! {FeEdition CLIENT} rangeTranscluders: positions {XnRegion default: NULL} ^self rangeTranscluders: positions with: NULL with: NULL with: Int32Zero with: NULL! {FeEdition CLIENT} rangeTranscluders: positions {XnRegion default: NULL} with: filter {Filter default: NULL} ^self rangeTranscluders: positions with: filter with: NULL with: Int32Zero with: NULL! {FeEdition CLIENT} rangeTranscluders: positions {XnRegion default: NULL} with: filter {Filter default: NULL} with: transitiveFilter {Filter default: NULL} ^self rangeTranscluders: positions with: filter with: transitiveFilter with: Int32Zero with: NULL! {FeEdition CLIENT} rangeTranscluders: positions {XnRegion default: NULL} with: filter {Filter default: NULL} with: transitiveFilter {Filter default: NULL} with: flags {Int32 default: Int32Zero} ^self rangeTranscluders: positions with: filter with: transitiveFilter with: flags with: NULL! {FeEdition CLIENT} rangeWorks ^self rangeWorks: NULL with: NULL with: 0 with: NULL! {FeEdition CLIENT} rangeWorks: region {XnRegion default: NULL} ^self rangeWorks: region with: NULL with: 0 with: NULL! {FeEdition CLIENT} rangeWorks: region {XnRegion default: NULL} with: filter {Filter default: NULL} ^self rangeWorks: region with: filter with: 0 with: NULL! {FeEdition CLIENT} rangeWorks: region {XnRegion default: NULL} with: filter {Filter default: NULL} with: flags {Int32 default: Int32Zero} ^self rangeWorks: region with: filter with: flags with: NULL! {(Stepper of: Bundle) CLIENT} retrieve ^self retrieve: NULL with: NULL with: 0! {(Stepper of: Bundle) CLIENT} retrieve: positions {XnRegion default: NULL} ^self retrieve: positions with: NULL with: 0! {(Stepper of: Bundle) CLIENT} retrieve: positions {XnRegion default: NULL} with: order {OrderSpec default: NULL} ^self retrieve: positions with: order with: 0! {FeEdition CLIENT} setRangeOwners: newOwner {ID} ^self setRangeOwners: newOwner with: NULL! {XnRegion CLIENT} sharedRegion: other {FeEdition} ^self sharedRegion: other with: 0! {FeEdition CLIENT} sharedWith: other {FeEdition} ^self sharedWith: other with: 0! {TableStepper CLIENT of: FeRangeElement} stepper ^self stepper: NULL with: NULL! {TableStepper CLIENT of: FeRangeElement} stepper: region {XnRegion default: NULL} ^self stepper: region with: NULL! ! !FeEdition methodsFor: 'smalltalk: passe'! {void} addCompletionDetector: detector {FeCompletionDetector} self passe! {void} addFillInDetector: detector {FeFillInDetector} self passe! {FeEdition} allBecome: newIdentities {FeEdition} with: positions {XnRegion default: NULL} self passe "makeRangeIdentical"! {PrimArray} asArray: positions {XnRegion default: NULL} with: ordering {OrderSpec default: NULL} self passe "use retrieve"! {XnRegion} keysLabelled: label {FeLabel} self passe! {FeEdition} parcelAt: position {Position} "Some subset of this Edition, containing the given position, all with the same owner { | in self and in self and v.owner == v2.owner }" self passe! {FeEdition of: ID and: FeEdition} parcels "Divides this Edition into pieces each of whose RangeElements are all owned by a single Club. { } > | in self and k1 == v2's owner }" self passe! {void} removeCompletionDetector: detector {FeCompletionDetector} self passe! {void} removeFillInDetector: detector {FeFillInDetector} self passe! {FeEdition} reorganize: oldRegion {XnRegion | NULL} with: oldOrder {OrderSpec | NULL} with: newRegion {XnRegion | NULL} with: newOrder {OrderSpec | NULL} "Rearrange the positions 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). This message is tentative and may be removed from the protocol." ^FeEdition on: (myBeEdition reorganize: oldRegion with: oldOrder with: newRegion with: newOrder) with: myLabel! {FeEdition} setAllOwners: newOwner {ID} with: region {XnRegion default: NULL} self passe "setRangeOwners"! {FeEdition} transclusions: positions {XnRegion default: NULL} with: directFilter {Filter default: NULL} with: indirectFilter {Filter default: NULL} with: flags {Int32 default: Int32Zero} with: otherTransclusions {FeEdition default: NULL} self passe "rangeTranscluders"! {void} unendorse: endorsements {CrossRegion} self passe "retract"! {Pair of: PrimSpec and: FeEdition} zoneAt: position {Position} "Essential. A zone containing the given position, all with the same kind of RangeElements." | result {Pair} | self passe. self thingToDo. "get rid of BeEdition protocol" result := myBeEdition zoneAt: position. ^Pair make: result left with: (FeEdition on: (result left cast: BeEdition) with: myLabel)! {FeEdition} zoneOf: values {PrimSpec} self passe! {TwoStepper of: PrimSpec and: FeEdition} zones: ordering {OrderSpec default: NULL} "Divides this Edition up into pieces all of whose RangeElements have the same PrimSpec. If no ordering is given, then uses the default full ordering for this CoordinateSpace." self passe! ! !FeEdition methodsFor: 'obsolete:'! {BooleanVar} includesKey: position {Position} "Whether the given position is in the Edition. Equivalent to this->domain ()->hasMember (position)" ^myBeEdition includesKey: position! {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)). { k | in self and v is same as value }" ^myBeEdition keysOf: value! ! !FeEdition methodsFor: 'destruct'! {void} destruct myBeEdition removeFeRangeElement: self. super destruct.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FeEdition class instanceVariableNames: ''! (FeEdition getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !FeEdition class methodsFor: 'smalltalk: defaults'! {FeEdition CLIENT} fromArray: values {PrimArray of: FeRangeElement} "Essential. 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. If a Region is given, then it must have the same count as the array. If no Region is given, then it is taken to be the IntegerRegion from 0 to the size of the array. If no OrderSpec is given, then it is the default ascending full ordering for that CoordinateSpace." ^self fromArray: values with: NULL with: NULL! {FeEdition CLIENT} fromArray: values {PrimArray of: FeRangeElement} with: keys {XnRegion default: NULL} "Essential. 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. If a Region is given, then it must have the same count as the array. If no Region is given, then it is taken to be the IntegerRegion from 0 to the size of the array. If no OrderSpec is given, then it is the default ascending full ordering for that CoordinateSpace." ^self fromArray: values with: keys with: NULL! ! !FeEdition class methodsFor: 'creation'! {FeEdition CLIENT} empty: keySpace {CoordinateSpace} "An empty Edition, with the given CoordinateSpace but no contents." ^FeEdition on: (CurrentGrandMap fluidGet newEmptyEdition: keySpace)! {FeEdition CLIENT} fromAll: keys {XnRegion} with: value {FeRangeElement} "Essential. A singleton Edition mapping from a Region of keys (potentially infinite) to a single value." ^FeEdition on: (CurrentGrandMap fluidGet newEditionWithAll: keys with: value carrier)! {FeEdition CLIENT} fromArray: values {PrimArray of: FeRangeElement} with: keys {XnRegion default: NULL} with: ordering {OrderSpec default: NULL} "Essential. 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. If a Region is given, then it must have the same count as the array. If no Region is given, then it is taken to be the IntegerRegion from 0 to the size of the array. If no OrderSpec is given, then it is the default ascending full ordering for that CoordinateSpace." | theKeys {XnRegion} theOrdering {OrderSpec} | keys == NULL ifTrue: [theKeys := IntegerRegion make: IntegerVar0 with: values count] ifFalse: [theKeys := keys]. ordering == NULL ifTrue: [theOrdering := theKeys coordinateSpace getAscending] ifFalse: [theOrdering := ordering]. values cast: PrimDataArray into: [ :data | ^FeEdition on: (CurrentGrandMap fluidGet newDataEdition: data with: theKeys with: theOrdering )] cast: PtrArray into: [ :ptr | ^FeEdition on: (CurrentGrandMap fluidGet newValueEdition: ptr with: theKeys with: theOrdering)]. ^NULL "fodder"! {FeEdition CLIENT} fromOne: key {Position} with: value {FeRangeElement} "A singleton Edition mapping from a single key to a single value." ^FeEdition on: (CurrentGrandMap fluidGet newEditionWith: key with: value carrier)! {FeEdition} on: be {BeEdition} | result {FeEdition} | result := self create: be with: FeLabel fake. be addFeRangeElement: result. ^result! {FeEdition} on: be {BeEdition} with: label {FeLabel} | result {FeEdition} | result := self create: be with: label. be addFeRangeElement: result. ^result! {FeEdition CLIENT} placeHolders: keys {XnRegion} "Essential. Create a new Edition mapping from each key in the Region to a new, unique PlaceHolder. The owner will have the capability to make them become something else." ^FeEdition on: (CurrentGrandMap fluidGet newPlaceHolders: keys)! ! !FeEdition class methodsFor: 'constants'! {Int32 constFn INLINE CLIENT} DIRECT.U.CONTAINERS.U.ONLY "For transcluders and works queries - only return objects which directly contain the sources of the query (i.e. excludes those which only contain it transitively through intermediate Editions)" ^4! {Int32 constFn INLINE CLIENT} FROM.U.OTHER.U.TRANSITIVE.U.CONTENTS "For sharedWith/sharedRegion/notSharedWith - look for RangeElements contained transitively within the other Edition" ^8! {Int32 constFn INLINE CLIENT} FROM.U.TRANSITIVE.U.CONTENTS "For transcluders, and works queries - consider RangeElements contained transitively inside the Edition, as well as just its immediate RangeElements" ^2! {Int32 constFn INLINE CLIENT} IGNORE.U.ARRAY.U.ORDERING "Used for retrieve. Allow the ArrayBundles in retrieve to be organized according to a different ordering." ^2! {Int32 constFn INLINE CLIENT} IGNORE.U.TOTAL.U.ORDERING "Used for retrieve. Allow non-contiguous chunks to be grouped together on retrieve, and allow the bundles to be presented in any order." ^1! {Int32 constFn INLINE CLIENT} LOCAL.U.PRESENT.U.ONLY "For transcluders and works queries - only guarantee to return items which are currently known to this server" ^1! {Int32 constFn INLINE CLIENT} OMIT.U.SHARED "For cost - omit the cost of shared material" ^1! {Int32 constFn INLINE CLIENT} otherTransitiveContents "For sharedWith/sharedRegion/notSharedWith" ^2! {Int32 constFn INLINE CLIENT} PRORATE.U.SHARED "For cost - prorate the cost of shared material among Editions sharing it" ^2! {Int32 constFn INLINE CLIENT} SEPARATE.U.OWNERS "For retrieve - ensure that each Bundle in a retrieve has a single owner" ^32! {Int32 constFn INLINE CLIENT} thisTransitiveContents "Used for version comparison." ^1! {Int32 constFn INLINE CLIENT} TO.U.TRANSITIVE.U.CONTENTS "For sharedRegion, sharedWith, notSharedWith queries - look down towards transitively contained material" ^2! {Int32 constFn INLINE CLIENT} TOTAL.U.SHARED "For cost - count the entire cost of shared material" ^3! ! !FeEdition class methodsFor: 'smalltalk: system'! info.stProtocol "{Int32 constFn INLINE CLIENT} DIRECT.U.CONTAINERS.U.ONLY {Int32 constFn INLINE CLIENT} FROM.U.OTHER.U.TRANSITIVE.U.CONTENTS {Int32 constFn INLINE CLIENT} FROM.U.TRANSITIVE.U.CONTENTS {Int32 constFn INLINE CLIENT} IGNORE.U.ARRAY.U.ORDERING {Int32 constFn INLINE CLIENT} IGNORE.U.TOTAL.U.ORDERING {Int32 constFn INLINE CLIENT} LOCAL.U.PRESENT.U.ONLY {Int32 constFn INLINE CLIENT} OMIT.U.SHARED {Int32 constFn INLINE CLIENT} PRORATE.U.SHARED {Int32 constFn INLINE CLIENT} SEPARATE.U.OWNERS {Int32 constFn INLINE CLIENT} TO.U.TRANSITIVE.U.CONTENTS {Int32 constFn INLINE CLIENT} TOTAL.U.SHARED {void CLIENT} addFillRangeDetector: detector {PrFillRangeDetector} {XuRegion CLIENT} canMakeRangeIdentical: newIdentities {FeEdition} with: positions {XuRegion default: NULL} {FeEdition CLIENT} combine: other {FeEdition} {CoordinateSpace CLIENT} coordinateSpace {FeEdition CLIENT} copy: positions {XuRegion} {IntegerVar CLIENT} cost: method {Int32} {IntegerVar CLIENT} count {XuRegion CLIENT} domain {void CLIENT} endorse: endorsements {CrossRegion} {CrossRegion CLIENT} endorsements {FeRangeElement CLIENT} get: position {Position} {BooleanVar CLIENT} hasPosition: position {Position} {BooleanVar CLIENT} isEmpty {BooleanVar CLIENT} isFinite {BooleanVar CLIENT} isRangeIdentical: other {FeEdition} {BooleanVar CLIENT} isRangeIdentical: other {FeEdition} with: region {XuRegion default: NULL} {FeEdition CLIENT} makeRangeIdentical: newIdentities {FeEdition} with: positions {XuRegion default: NULL} {Mapping CLIENT} mapSharedOnto: other {FeEdition} {Mapping CLIENT} mapSharedTo: other {FeEdition} {FeEdition CLIENT} notSharedWith: other {FeEdition} with: flags {Int32 default: Int32Zero} {XuRegion CLIENT} positionsLabelled: label {FeLabel} {XuRegion CLIENT} positionsOf: value {FeRangeElement} {IDRegion CLIENT} rangeOwners: positions {XuRegion default: NULL} {FeEdition CLIENT} rangeTranscluders: positions {XuRegion default: NULL} with: directFilter {Filter default: NULL} with: indirectFilter {Filter default: NULL} with: flags {Int32 default: Int32Zero} with: otherTrail {FeEdition default: NULL} {FeEdition CLIENT} rangeWorks: positions {XuRegion default: NULL} with: filter {Filter default: NULL} with: flags {Int32 default: Int32Zero} with: otherTrail {FeEdition default: NULL} {FeEdition CLIENT} rebind: position {Position} with: edition {FeEdition} {void CLIENT} removeFillRangeDetector: detector {PrFillRangeDetector} {FeEdition CLIENT} replace: other {FeEdition} {void CLIENT} retract: endorsements {CrossRegion} {(Stepper of: Bundle) CLIENT} retrieve: positions {XuRegion default: NULL} with: order {OrderSpec default: NULL} with: flags {Int32 default: Int32Zero} {FeEdition CLIENT} setRangeOwners: newOwner {ID} with: positions {XuRegion default: NULL} {XuRegion CLIENT} sharedRegion: other {FeEdition} with: flags {Int32 default: Int32Zero} {FeEdition CLIENT} sharedWith: other {FeEdition} with: flags {Int32 default: Int32Zero} {TableStepper CLIENT of: FeRangeElement} stepper: region {XuRegion default: NULL} with: order {OrderSpec default: NULL} {FeRangeElement CLIENT} theOne {FeEdition CLIENT} transformedBy: mapping {Mapping} {CrossRegion CLIENT} visibleEndorsements {FeEdition CLIENT} with: position {Position} with: value {FeRangeElement} {FeEdition CLIENT} withAll: positions {XuRegion} with: value {FeRangeElement} {FeEdition CLIENT} without: position {Position} {FeEdition CLIENT} withoutAll: positions {XuRegion} "! !FeRangeElement subclass: #FeIDHolder instanceVariableNames: 'myBeIDHolder {BeIDHolder}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-nkernel'! FeIDHolder comment: 'An object for having an ID in the range of an Edition. Tentative feature.'! (FeIDHolder getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !FeIDHolder methodsFor: 'accessing'! {FeRangeElement} again ^self! {BooleanVar} canMakeIdentical: newIdentity {FeRangeElement} (self isIdentical: newIdentity) ifFalse: [self unimplemented]. ^true! {ID CLIENT} iD "Essential. The ID in this holder." ^myBeIDHolder iD! {void} makeIdentical: newIdentity {FeRangeElement} (self isIdentical: newIdentity) ifFalse: [self unimplemented]! ! !FeIDHolder methodsFor: 'server accessing'! {BeRangeElement | NULL} fetchBe ^myBeIDHolder! {BeRangeElement} getOrMakeBe ^myBeIDHolder! ! !FeIDHolder methodsFor: 'private: create'! create: be {BeIDHolder} super create. myBeIDHolder := be.! ! !FeIDHolder methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << 'IDHolder(' << self iD << ')'! ! !FeIDHolder methodsFor: 'destruct'! {void} destruct myBeIDHolder removeFeRangeElement: self. super destruct.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FeIDHolder class instanceVariableNames: ''! (FeIDHolder getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !FeIDHolder class methodsFor: 'creation'! {FeIDHolder CLIENT} make: iD {ID} "Essential. Make a single IDHolder with the given ID. Tentative feature." ^FeIDHolder on: (CurrentGrandMap fluidGet newIDHolder: iD)! {FeIDHolder} on: be {BeIDHolder} | result {FeIDHolder} | result := self create: be. be addFeRangeElement: result. ^result! ! !FeIDHolder class methodsFor: 'smalltalk: system'! info.stProtocol "{ID CLIENT} iD "! !FeRangeElement subclass: #FeLabel instanceVariableNames: 'myBeLabel {BeLabel | NULL}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-nkernel'! FeLabel comment: 'An identity attached to a RangeElement within an Edition.'! (FeLabel getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !FeLabel methodsFor: 'server accessing'! {BeRangeElement | NULL} fetchBe ^myBeLabel! {BeRangeElement} getOrMakeBe myBeLabel == NULL ifTrue: [myBeLabel _ CurrentGrandMap fluidGet newLabel. myBeLabel addFeRangeElement: self]. ^myBeLabel! ! !FeLabel methodsFor: 'client accessing'! {FeRangeElement} again self unimplemented. ^NULL "fodder"! {BooleanVar} canMakeIdentical: newIdentity {FeRangeElement} (self isIdentical: newIdentity) ifFalse: [self unimplemented]. ^true! {void} makeIdentical: newIdentity {FeRangeElement} self unimplemented! ! !FeLabel methodsFor: 'destruct'! {void} destruct myBeLabel == NULL ifFalse: [myBeLabel removeFeRangeElement: self]. super destruct.! ! !FeLabel methodsFor: 'creation'! create: label {BeLabel | NULL} super create. myBeLabel _ label.! ! !FeLabel methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '(' << self getOrMakeBe hashForEqual << ')'! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FeLabel class instanceVariableNames: ''! (FeLabel getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !FeLabel class methodsFor: 'creation'! {FeLabel} fake "The label will be made on demand." ^self on: NULL! {FeLabel CLIENT} make "Essential. Create a new unique Label" ^FeLabel fake! {FeLabel} on: label {BeLabel | NULL} | result {FeLabel} | result := self create: label. label ~~ NULL ifTrue: [label addFeRangeElement: result]. ^result! !FeRangeElement subclass: #FePlaceHolder instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-nkernel'! FePlaceHolder comment: 'Represents a piece of pure identity in the Server.'! (FePlaceHolder getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !FePlaceHolder methodsFor: 'accessing'! {void} addFillDetector: detector {FeFillDetector} self getOrMakeBe cast: BePlaceHolder into: [ :p | p addDetector: detector] others: ["in case it changed behind our backs" detector filled: self again]! {FeRangeElement} again self subclassResponsibility! {BooleanVar} canMakeIdentical: newIdentity {FeRangeElement} self subclassResponsibility! {void} makeIdentical: newIdentity {FeRangeElement} self subclassResponsibility! ! !FePlaceHolder methodsFor: 'server accessing'! {BeRangeElement | NULL} fetchBe self subclassResponsibility! {BeRangeElement} getOrMakeBe self subclassResponsibility! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FePlaceHolder class instanceVariableNames: ''! (FePlaceHolder getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !FePlaceHolder class methodsFor: 'creation'! {FePlaceHolder} fake: edition {BeEdition} with: key {Position} ^FeVirtualPlaceHolder create: edition with: key! {FePlaceHolder} on: be {BeRangeElement} | result {FeRangeElement} | result := FeActualPlaceHolder create: be. be addFeRangeElement: result. ^result cast: FePlaceHolder! ! !FePlaceHolder class methodsFor: 'smalltalk: passe'! {FePlaceHolder} grand: iD {ID} self passe.! !FePlaceHolder subclass: #FeActualPlaceHolder instanceVariableNames: 'myRangeElement {BeRangeElement}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-nkernel'! FeActualPlaceHolder comment: 'Actually has a persistent individual PlaceHolder on the Server, or used to, and now has a pointer to the rangeElement it became.'! (FeActualPlaceHolder getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !FeActualPlaceHolder methodsFor: 'client accessing'! {FeRangeElement} again Dean shouldImplement. "This must hold onto an FeRangeElement so that the label is properly maintained." myRangeElement cast: BePlaceHolder into: [:pl | ^self "No change."] others: [^myRangeElement makeFe: NULL]. ^NULL "fodder"! {BooleanVar} canMakeIdentical: newIdentity {FeRangeElement} (self isIdentical: newIdentity) ifFalse: [self unimplemented]. ^true! {void} makeIdentical: newIdentity {FeRangeElement} "Consolidate this PlaceHolder to the newIdentity. Return true if successful." "Check permissions and forward the operation after coercing the newIdentity to a persistent RangeElement." "myRangeElement will tell me to forward to another RangeElement." (CurrentKeyMaster fluidGet hasAuthority: self owner) ifFalse: [Heaper BLAST: #MustBeOwner]. myRangeElement makeIdentical: newIdentity getOrMakeBe! {ID} owner "MyBeRangeElement will know it." ^myRangeElement owner! {void} removeFillDetector: detector {FeFillDetector} (Heaper isDestructed: myRangeElement) ifFalse: [myRangeElement cast: BePlaceHolder into: [ :p | p removeDetector: detector] others: []]! ! !FeActualPlaceHolder methodsFor: 'server accessing'! {BeRangeElement | NULL} fetchBe ^myRangeElement! {void} forwardTo: element {BeRangeElement} "myRangeElement has become something else. Forward to the new thing." myRangeElement removeFeRangeElement: self. myRangeElement _ element. myRangeElement addFeRangeElement: self.! {BeRangeElement} getOrMakeBe ^myRangeElement! ! !FeActualPlaceHolder methodsFor: 'private: create'! create: be {BeRangeElement} super create. myRangeElement := be.! ! !FeActualPlaceHolder methodsFor: 'destruct'! {void} destruct myRangeElement removeFeRangeElement: self. super destruct.! !FePlaceHolder subclass: #FeGrandPlaceHolder instanceVariableNames: 'myID {ID}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-nkernel'! FeGrandPlaceHolder comment: 'Fakes a PlaceHolder in the GrandMap by just remembering the key.'! (FeGrandPlaceHolder getOrMakeCxxClassDescription) attributes: ((Set new) add: #OBSOLETE; add: #SMALLTALK.ONLY; add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !FeGrandPlaceHolder methodsFor: 'client accessing'! {FeRangeElement} again ^CurrentGrandMap fluidGet getOrMakeFe: myID! {BooleanVar} canMakeIdentical: newIdentity {FeRangeElement} (self isIdentical: newIdentity) ifFalse: [self unimplemented]. ^true! {void} makeIdentical: newIdentity {FeRangeElement} "Consolidate this PlaceHolder to the newIdentity. Return true if successful." "Check permissions and then try storing the other guy into the grandMap." self thingToDo. "This doesn't need to force newIdentity into a BeRangeElement." (CurrentKeyMaster fluidGet hasAuthority: self owner) ifFalse: [Heaper BLAST: #MustBeOwner]. (CurrentGrandMap fluidGet at: myID tryIntroduce: newIdentity getOrMakeBe) ifFalse: [Heaper BLAST: #CantMakeIdentical]! {ID} owner "Ask the GrandMap who owns this ID" ^CurrentGrandMap fluidGet placeOwnerID: myID! {void} removeFillDetector: detector {FeFillDetector} Heaper BLAST: #NotInSet! ! !FeGrandPlaceHolder methodsFor: 'server accessing'! {BeRangeElement | NULL} fetchBe ^NULL! {BeRangeElement} getOrMakeBe "Create a new persistent PlaceHolder and register it in the GrandMap." | result {BeRangeElement} | InitialOwner fluidBind: self owner during: [result _ CurrentGrandMap fluidGet newPlaceHolder. (CurrentGrandMap fluidGet at: myID tryIntroduce: result) ifTrue: [^result] ifFalse: [^self again getOrMakeBe]]! ! !FeGrandPlaceHolder methodsFor: 'private: create'! create: iD {ID} super create. myID := iD! !FePlaceHolder subclass: #FeVirtualPlaceHolder instanceVariableNames: ' myEdition {BeEdition} myKey {Position}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-nkernel'! FeVirtualPlaceHolder comment: 'Fakes a PlaceHolder by having an Edition and a key.'! (FeVirtualPlaceHolder getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !FeVirtualPlaceHolder methodsFor: 'client accessing'! {FeRangeElement} again ^myEdition get: myKey! {BooleanVar} canMakeIdentical: newIdentity {FeRangeElement} (self isIdentical: newIdentity) ifFalse: [self unimplemented]. ^true! {void} makeIdentical: newIdentity {FeRangeElement} "Consolidate this PlaceHolder to the newIdentity. Return true if successful." "Check permissions and coerce both of us and have the BeRangeElements try." self thingToDo. "This doesn't need to force newIdentity into a BeRangeElement." (CurrentKeyMaster fluidGet hasAuthority: self owner) ifFalse: [Heaper BLAST: #MustBeOwner]. self getOrMakeBe makeIdentical: newIdentity getOrMakeBe! {ID} owner ^myEdition ownerAt: myKey! {void} removeFillDetector: detector {FeFillDetector} Heaper BLAST: #NotInSet! ! !FeVirtualPlaceHolder methodsFor: 'server accessing'! {BeRangeElement | NULL} fetchBe ^NULL! {BeRangeElement} getOrMakeBe "Force the ent to generate a beRangeElement at myKey." ^myEdition getOrMakeBe: myKey! ! !FeVirtualPlaceHolder methodsFor: 'private: create'! create: edition {BeEdition} with: key {Position} super create. myEdition := edition. myKey := key! !FeRangeElement subclass: #FeWork instanceVariableNames: ' myKeyMaster {FeKeyMaster | NULL} myAuthor {ID} amWaiting {BooleanVar} myBeWork {BeWork} myStatusDetectors {PrimSet | NULL of: FeStatusDetector} myRevisionDetectors {PrimSet | NULL of: FeRevisionDetector}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-nkernel'! FeWork comment: 'A persistent identity for a changeable object.'! (FeWork getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !FeWork methodsFor: 'grab status'! {void} addStatusDetector: detector {FeStatusDetector} "Essential. Add a detector which will be notified whenever the locking status of this Work object changes. See FeStatusDetector::grabbed (Work *, ID *) / released (Work *)." myStatusDetectors == NULL ifTrue: [myStatusDetectors := PrimSet weak: 7 with: (StatusDetectorExecutor make: self)]. myStatusDetectors introduce: detector! {BooleanVar CLIENT} canRead "Return whether you have read permission. If grabbed, returns TRUE (because a grabber can always read); if released, then returns whether the CurrentKeyMaster has sufficient permission to read the work. (Read or Edit permission is required.) Does not check any other KeyMasters you may be holding. Note: Be careful of synchronization problems, since the permissions may change between when you ask this question and when you try to actually read the Work." | ckm {FeKeyMaster} | ckm := CurrentKeyMaster fluidFetch. ^self canRevise or: [ckm ~~ NULL and: [myBeWork canBeReadBy: ckm]]! {BooleanVar CLIENT} canRevise "Return whether the BeWork is grabbed by you through this FeWork. Note: Be careful of synchronization problems, since the permissions may change before you try to actually revise it, causing you to lose your grab." ^(myBeWork fetchLockingWork basicCast: Heaper star) == self! {void CLIENT} grab "Essential. Grab the Work to prevent other clients from revising it. Requires edit permission. Snapshots the CurrentKeyMaster and CurrentAuthor (to be used to maintain the grab and report what was done with it). Fails if - someone else has it grabbed - the CurrentKeyMaster does not have edit permission - the CurrentKeyMaster does not have signature authority of the CurrentAuthor If this Work was already grabbed by you, then it updates the KeyMaster and Author it holds. (If the regrab fails, the old grab will remain in effect.) The grab will be released - upon a release request - if the KeyMaster loses authority to edit - if the KeyMaster loses the signature authority of the Author - at the end of the session - when the FeWork object is deallocated (if an FeWork was dropped while grabbed, {by destroying the promise for it, or by loss of connection} it will be deallocated 'eventually')" | oldAuthor {ID} | "Check that I have edit permissions" (myBeWork canBeEditedBy: CurrentKeyMaster fluidGet) ifFalse: [Heaper BLAST: #MustHaveEditPermission]. (CurrentKeyMaster fluidGet hasSignatureAuthority: CurrentAuthor fluidGet) ifFalse: [Heaper BLAST: #MustHaveAuthorSignatureAuthority]. oldAuthor := myAuthor. myAuthor := CurrentAuthor fluidFetch. myKeyMaster ~~ NULL ifTrue: [myKeyMaster unregisterWork: self]. myKeyMaster := CurrentKeyMaster fluidFetch. myKeyMaster registerWork: self. "Try to gain mutual exclusion" (myBeWork tryLock: self) ifFalse: [myAuthor := NULL. myKeyMaster := NULL. Heaper BLAST: #WorkIsLockedBySomeoneElse]. amWaiting ifTrue: ["code has been changed in such a way as to allow a race condition" Heaper BLAST: #FatalError]. Ravi thingToDo. "register with author Club to find out when signature authority changes" "Notify all the status detectors" (myStatusDetectors ~~ NULL and: [oldAuthor == NULL or: [(oldAuthor isEqual: myAuthor) not]]) ifTrue: [myStatusDetectors stepper forEach: [ :stat {FeStatusDetector} | self thingToDo. "reasons" stat grabbed: self with: myAuthor with: IntegerVarZero]].! {ID CLIENT} grabber "Essential. If you have edit authority, and someone has the BeWork grabbed, then return the Club ID that was the value of his CurrentAuthor when he grabbed it; otherwise blast. Requiring edit authority is appropriate here, because it is exactly editors who are affected by competing grabs, and need to know who has the grab. Once the BeWork is revised, anyone who can read the current trail can see the revision, but the grab state doesn't necessarily imply that the BeWork will be revised soon, or ever." | grabber {FeWork} ckm {FeKeyMaster} | self canRevise ifTrue: [^myAuthor]. ckm := CurrentKeyMaster fluidGet. (myBeWork fetchEditClub ~~ NULL and: [ckm hasAuthority: myBeWork fetchEditClub]) ifFalse: [Heaper BLAST: #MustHaveEditAuthority]. grabber := myBeWork fetchLockingWork. grabber == NULL ifTrue: [Heaper BLAST: #NotGrabbed]. ^grabber getAuthor! {void CLIENT} release "Essential. Release the grab on this Work; if a requestGrab had been pending, remove it. Does nothing if it is already unlocked." | becameUnlocked {BooleanVar} | (amWaiting or: [self canRevise]) ifFalse: [^VOID]. becameUnlocked := myBeWork tryUnlock: self. myKeyMaster unregisterWork: self. amWaiting := false. myKeyMaster := NULL. myAuthor := NULL. becameUnlocked ifTrue: ["Notify all the status detectors" myStatusDetectors ~~ NULL ifTrue: [myStatusDetectors stepper forEach: [ :stat {FeStatusDetector} | stat released: self with: IntegerVarZero]]].! {void} removeLastStatusDetector "Essential. Last detector has gone away" myStatusDetectors := NULL! {void CLIENT} requestGrab "Essential. Registers a request so that the next time this Work would have been released and no other grab requests are outstanding the CurrentKeyMaster (as of making the request) has edit permission, and has signature authority of the CurrentAuthor (as of making the request), it will be grabbed by this FeWork. If this FeWork already has the Work grabbed, then the request has no effect. To find out when the grab succeeds, place Status Detectors on the Work. (If there are competing requestGrabs for a BeWork, the queueing of the requests may not be FIFO, but is starvation-free.) Note that if you have a requestGrab outstanding on a BeWork through one FeWork, and release a grab you have through another, your requestGrab has no special priority over those of other users." self canRevise ifTrue: [(myBeWork canBeEditedBy: CurrentKeyMaster fluidGet) ifFalse: [Heaper BLAST: #MustHaveEditPermission]. (CurrentKeyMaster fluidGet hasSignatureAuthority: CurrentAuthor fluidGet) ifFalse: [Heaper BLAST: #MustHaveAuthorSignatureAuthority]. myAuthor := CurrentAuthor fluidFetch. myKeyMaster unregisterWork: self. myKeyMaster := CurrentKeyMaster fluidFetch. myKeyMaster registerWork: self. ^VOID]. amWaiting ifTrue: [myKeyMaster unregisterWork: self]. amWaiting := true. myKeyMaster := CurrentKeyMaster fluidGet. myAuthor := CurrentAuthor fluidGet. self updateStatus. myKeyMaster registerWork: self.! {FeStatusDetector CLIENT} statusDetector "Essential. Return a detector which will be notified whenever the locking status of this Work changes. See FeStatusDetector::grabbed (Work *, ID *) / released (Work *)." Dean shouldImplement. self addStatusDetector: NULL. ^NULL "fodder"! ! !FeWork methodsFor: 'contents'! {FeEdition CLIENT} edition "Essential. Return the current Edition. Succeeds if the Work is already grabbed, or if the CurrentKeyMaster has either Read or Edit permission. Note: If this is an unsponsored Work, the Edition might have been discarded, in which case this operation will blast." self canRead ifFalse: [Heaper BLAST: #MustHaveReadPermission]. ^myBeWork edition! {void CLIENT} revise: newEdition {FeEdition} "Essential. Change the current Edition of this work to newEdition. The Work must be grabbed The grabber is recorded as the author who made the revision. (This is the fundamental write operation.)" self canRevise ifFalse: [Heaper BLAST: #WorkMustBeGrabbed]. CurrentKeyMaster fluidBind: myKeyMaster during: [CurrentAuthor fluidBind: myAuthor during: [myBeWork revise: newEdition]]! ! !FeWork methodsFor: 'permissions'! {ID CLIENT} editClub "Essential. Return the club which has permission to revise this Work. Blasts if noone can (i.e. editor has been removed)." myBeWork fetchEditClub == NULL ifTrue: [Heaper BLAST: #EditorRemoved]. ^myBeWork fetchEditClub! {ID CLIENT} historyClub "Essential. Return the club which will be recorded as the initial club for frozen Works in the history trail. Blasts if there is no trail being generated." | result {ID} | result := myBeWork fetchHistoryClub. result == NULL ifTrue: [Heaper BLAST: #NoHistoryClub]. ^result! {ID CLIENT} readClub "Essential. Return the club which has permission to read this Work. Blasts if the read Club has been removed (in that case, only those who have edit permission can read the Work)." myBeWork fetchReadClub == NULL ifTrue: [Heaper BLAST: #ReadClubRemoved]. ^myBeWork fetchReadClub! {void CLIENT} removeEditClub "Essential. Irrevocably remove edit permission. Requires ownership authority." (CurrentKeyMaster fluidGet hasAuthority: self owner) ifFalse: [Heaper BLAST: #MustBeOwner]. myBeWork setEditClub: NULL! {void CLIENT} removeReadClub "Essential. Irrevocably remove read permission (although you should note that editors are still able to read, if there are any). Requires ownership authority." (CurrentKeyMaster fluidGet hasAuthority: self owner) ifFalse: [Heaper BLAST: #MustBeOwner]. myBeWork setReadClub: NULL! {void CLIENT} setEditClub: club {ID | NULL} "Essential. Change who has edit permission. Requires ownership authority. Aborts if the Work doesn't have an edit Club." (CurrentKeyMaster fluidGet hasAuthority: self owner) ifFalse: [Heaper BLAST: #MustBeOwner]. myBeWork fetchEditClub == NULL ifTrue: [Heaper BLAST: #EditClubIrrevocablyRemoved]. myBeWork setEditClub: club! {void CLIENT} setHistoryClub: club {ID | NULL} "Essential. Change the initial read Club for frozen Works in the trail. Requires ownership authority. Setting it to NULL turns off the recording of history." (CurrentKeyMaster fluidGet hasAuthority: self owner) ifFalse: [Heaper BLAST: #MustBeOwner]. myBeWork setHistoryClub: club! {void CLIENT} setReadClub: club {ID | NULL} "Essential. Change who has read permission. Requires ownership authority. Aborts if the works doesn't have a read Club." (CurrentKeyMaster fluidGet hasAuthority: self owner) ifFalse: [Heaper BLAST: #MustBeOwner]. myBeWork fetchReadClub == NULL ifTrue: [Heaper BLAST: #ReadClubIrrevocablyRemoved]. myBeWork setReadClub: club! ! !FeWork methodsFor: 'endorsing'! {void CLIENT} endorse: additionalEndorsements {CrossRegion} "Essential. 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 signature authority of all of the Clubs used to endorse; will blast and do nothing if any of the required authority is lacking. The token IDs must not be named IDs." FeRangeElement validateEndorsement: additionalEndorsements with: CurrentKeyMaster fluidGet. myBeWork endorse: additionalEndorsements! {CrossRegion CLIENT} endorsements "Essential. Return all of the endorsements which have been placed on this Work and are not currently retracted. (Endorsements are used to filter various operations which return sets of Works. See FeEdition::rangeTranscluders() for one way to find this work by filtering for its endorsements.)" ^myBeWork endorsements! {void CLIENT} retract: removedEndorsements {CrossRegion} "Essential. Removes endorsements from this Work. This requires the signature authority of all of the Clubs whose endorsements are in the list; will blast and do nothing if any of the required authority is lacking. Ignores all endorsements which you could have removed, but which don't happen to be there right now." FeRangeElement validateEndorsement: removedEndorsements with: CurrentKeyMaster fluidGet. myBeWork retract: removedEndorsements! ! !FeWork methodsFor: 'sponsoring'! {void CLIENT} sponsor: clubs {IDRegion} "Essential. Add to the list of sponsors of this Work. Requires signature authority of all of the Clubs in the set." FeRangeElement validateSignature: clubs with: CurrentKeyMaster fluidGet. myBeWork sponsor: clubs! {IDRegion CLIENT} sponsors "Essential. All of the Clubs which are sponsoring this Work to keep it from being discarded. What sort of permissions does this require?" ^myBeWork sponsors! {void CLIENT} unsponsor: clubs {IDRegion} "Essential. End sponsorship of this Work by all of the listed Clubs. Requires signature authority of all of the Clubs in the set, even if they are not currently sponsors. Should this use the CurrentKeyMaster? Or the internal KeyMaster if it is grabbed?" FeRangeElement validateSignature: clubs with: CurrentKeyMaster fluidGet. myBeWork unsponsor: clubs! ! !FeWork methodsFor: 'server grab status'! {void} updateStatus "The authority of my KeyMaster has changed and I need to update my status" "If I was grabbing and lost permission to edit, or signature authority for the author, evict myself else if I was waiting for a grab and gained permission to do so and the Work is ungrabbed grab it" Ravi knownBug. "Add mechanism to notify when signature Club of Author is changed" self canRevise ifTrue: [((myBeWork canBeEditedBy: myKeyMaster) and: [myKeyMaster hasSignatureAuthority: myAuthor]) ifFalse: [self release]] ifFalse: [(amWaiting and: [myKeyMaster ~~ NULL and: [(myBeWork canBeEditedBy: myKeyMaster) and: [myKeyMaster hasSignatureAuthority: myAuthor]]]) ifTrue: [(myBeWork tryLock: self) ifTrue: [amWaiting := false. myStatusDetectors ~~ NULL ifTrue: [myStatusDetectors stepper forEach: [ :stat {FeStatusDetector} | self thingToDo. "reasons" stat grabbed: self with: myAuthor with: IntegerVarZero]]]]]! ! !FeWork methodsFor: 'server contents'! {void} triggerRevisionDetectors: contents {FeEdition} with: author {ID} with: time {IntegerVar} with: sequence {IntegerVar} "Trigger all my immediate RevisionDetectors who can read the Work" myRevisionDetectors stepper forEach: [ :pair {Pair of: FeKeyMaster and: FeRevisionDetector} | (myBeWork canBeReadBy: (pair left cast: FeKeyMaster)) ifTrue: [(pair right cast: FeRevisionDetector) revised: self with: contents with: author with: time with: sequence]]! ! !FeWork methodsFor: 'server accessing'! {ID | NULL} fetchAuthor ^myAuthor! {BeRangeElement | NULL} fetchBe ^myBeWork! {ID} getAuthor myAuthor == NULL ifTrue: [Heaper BLAST: #NoAuthor]. ^myAuthor! {BeRangeElement} getOrMakeBe ^myBeWork! ! !FeWork methodsFor: 'protected: create'! create: be {BeWork} super create. myBeWork := be. myKeyMaster := NULL. myAuthor _ NULL. amWaiting := false. myStatusDetectors := NULL. myRevisionDetectors := NULL. myKeyMaster := NULL.! ! !FeWork methodsFor: 'destruct'! {void} destruct myBeWork removeFeRangeElement: self. myBeWork tryUnlock: self. myKeyMaster ~~ NULL ifTrue: [myKeyMaster unregisterWork: self]. super destruct.! ! !FeWork methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << 'Work(' << 'ids: ' << (FeServer iDsOf: self). self canRead ifTrue: [oo << ' contents: ' << self edition]. self canRevise ifTrue: [oo << ' (grabbed)']. oo << ')'! ! !FeWork methodsFor: 'accessing'! {FeRangeElement} again self thingToDo. "deal with work consolidation" ^self! {BooleanVar} canMakeIdentical: newIdentity {FeRangeElement} (self isIdentical: newIdentity) ifFalse: [self unimplemented]. ^true! {void} makeIdentical: newIdentity {FeRangeElement} self unimplemented. "deal with work consolidation"! ! !FeWork methodsFor: 'smalltalk: passe'! {void} addSponsors: clubs {IDRegion} self passe "sponsor"! {ID} currentAuthor self passe "grabber"! {void} lock self passe! {ID} lockingClub self passe.! {void} removeSponsors: clubs {IDRegion} self passe! {void} requestLock "Essential. Registers a request so that the next time this Work would have been unlocked and the KeyMaster has edit permission, it will be locked by this client. If this client already has it locked, then it has no effect. To find out when this happens, place Status Detectors on the Work." self passe. amWaiting := true. self updateStatus.! {void} setKeyMaster: km {FeKeyMaster | NULL} "Essential. Change the authority through which the Work is being read and revised. Blasts if the Work is locked and the new authority is insufficient to maintain the lock." self passe. "Subsumed by grab" "Check that the new authority can maintain existing lock" (self canRevise and: [km == NULL or: [(myBeWork canBeEditedBy: km) not]]) ifTrue: [Heaper BLAST: #MustHaveEditPermission]. self knownBug. "check the CurrentAuthor." "Change the km and check for change in read permission" myAuthor _ CurrentAuthor fluidGet. myKeyMaster ~~ NULL ifTrue: [myKeyMaster unregisterWork: self]. myKeyMaster := km. myKeyMaster ~~ NULL ifTrue: [myKeyMaster registerWork: self]. "Update Detectors and cached information" self updateStatus! {void} unendorse: removedEndorsements {CrossRegion} self passe "retract"! {void} unlock "Essential. Release the lock on this Work. Does nothing if it is already unlocked." self passe. (myBeWork tryUnlock: self) ifTrue: ["Notify all the status detectors" myStatusDetectors ~~ NULL ifTrue: [myStatusDetectors stepper forEach: [ :stat {FeStatusDetector} | stat canRevise: self with: false]]]! ! !FeWork methodsFor: 'history'! {void} addRevisionDetector: detector {FeRevisionDetector} "Essential. Trigger a Detector whenever there is a revision to the Work which the CurrentKeyMaster can see. If this detector has already been added, then the old KeyMaster associated with it is replaced with the CurrentKeyMaster. See RevisionDetector::revised (Edition * contents, ID * author, IntegerVar sequence, IntegerVar time)." myRevisionDetectors == NULL ifTrue: [myRevisionDetectors := PrimSet weak: 7 with: (RevisionDetectorExecutor make: self). myBeWork addRevisionWatcher: self] ifFalse: [myRevisionDetectors stepper forEach: [ :pair {Pair} | (detector isEqual: pair right) ifTrue: [myRevisionDetectors remove: pair]]]. myRevisionDetectors introduce: (Pair make: CurrentKeyMaster fluidGet with: detector)! {ID CLIENT} lastRevisionAuthor "The ID of the author of the last revision of this Work to its current Edition, or its creation if it hasn't been revised since. The Work must be grabbed, or the CurrentKeyMaster must be able to exercise the authority of the Read, Edit, or History Club." self canReadHistory ifFalse: [Heaper BLAST: #MustHaveReadPermission]. ^myBeWork lastRevisionAuthor! {IntegerVar CLIENT} lastRevisionNumber "The sequence number of the last revision of this Work to its current Edition, or its creation if it hasn't been revised since. The Work must be grabbed, or the CurrentKeyMaster must be able to exercise the authority of the Read, Edit, or History Club." self canReadHistory ifFalse: [Heaper BLAST: #MustHaveReadPermission]. ^myBeWork lastRevisionNumber! {IntegerVar CLIENT} lastRevisionTime "The time of the last revision of this Work to its current Edition, or its creation if it hasn't been revised since. The Work must be grabbed, or the CurrentKeyMaster must be able to exercise the authority of the Read, Edit, or History Club." self canReadHistory ifFalse: [Heaper BLAST: #MustHaveReadPermission]. ^myBeWork lastRevisionTime! {void} removeLastRevisionDetector "Essential. Inform the work that its last revision detector has gone away." myRevisionDetectors := NULL. myBeWork removeRevisionWatcher: self! {FeRevisionDetector CLIENT} revisionDetector "Essential. Return a detector tht will trigger whenever there is a revision to the Work which the CurrentKeyMaster can see. See RevisionDetector::revised (Edition * contents, ID * author, IntegerVar sequence, IntegerVar time)." Dean shouldImplement. self addRevisionDetector: NULL. ^NULL "fodder"! {FeEdition CLIENT} revisions "Return the revision trail of the receiver. The trail will be empty if no revisions have been recorded. The trail is updated immediately when the Work is revised. In order to get the trail, either the Work must be grabbed, or you must be a member of the Read, Edit, or History Clubs." self knownBug. "This needs a label." self canReadHistory ifFalse: [Heaper BLAST: #MustHaveReadPermission]. ^FeEdition on: myBeWork revisions! ! !FeWork methodsFor: 'private:'! {BooleanVar} canReadHistory "self canRead or CurrentKeyMaster has authority of the historyClub" | ckm {FeKeyMaster} | ckm := CurrentKeyMaster fluidFetch. ^self canRead or: [ckm ~~ NULL and: [myBeWork fetchHistoryClub ~~ NULL and: [ckm hasAuthority: myBeWork fetchHistoryClub]]]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FeWork class instanceVariableNames: ''! (FeWork getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !FeWork class methodsFor: 'exceptions: exceptions'! bomb.ReleaseWork: CHARGE {FeWork wimpy} ^[(CHARGE quickCast: FeWork) release]! ! !FeWork class methodsFor: 'creation'! {FeWork CLIENT} make: contents {FeEdition} "Essential. Create a new Work whose initial contents are the given Edition. The reader, editor, owner, sponsor, and KeyMaster come from the fluid environment. If the KeyMaster has edit permission, then the Work is initially grabbed by it. Note: This does not assign it a global ID; that must be done separately (see Server::assignID)." FeKeyMaster assertSponsorship. FeKeyMaster assertSignatureAuthority. ^(CurrentGrandMap fluidGet newWork: contents) makeLockedFeWork! {FeWork} on: be {BeWork} | result {FeWork} | result := self create: be. be addFeRangeElement: result. ^result! ! !FeWork class methodsFor: 'smalltalk: system'! info.stProtocol "{void CLIENT} addRevisionDetector: detector {PrRevisionDetector} {void CLIENT} addStatusDetector: detector {PrStatusDetector} {BooleanVar CLIENT} canRead {BooleanVar CLIENT} canRevise {ID CLIENT} editClub {FeEdition CLIENT} edition {void CLIENT} endorse: added {CrossRegion} {CrossRegion CLIENT} endorsements {void CLIENT} grab {ID CLIENT} grabber {ID CLIENT} historyClub {ID CLIENT} lastRevisionAuthor {IntegerVar CLIENT} lastRevisionNumber {IntegerVar CLIENT} lastRevisionTime {ID CLIENT} readClub {void CLIENT} release {void CLIENT} removeEditClub {void CLIENT} removeReadClub {void CLIENT} removeRevisionDetector: detector {PrRevisionDetector} {void CLIENT} removeStatusDetector: detector {PrStatusDetector} {void CLIENT} requestGrab {void CLIENT} retract: removed {CrossRegion} {void CLIENT} revise: newEdition {FeEdition} {FeEdition CLIENT} revisions {void CLIENT} setEditClub: club {ID} {void CLIENT} setHistoryClub: club {ID | NULL} {void CLIENT} setReadClub: club {ID} {void CLIENT} sponsor: clubs {IDRegion} {IDRegion CLIENT} sponsors {void CLIENT} unsponsor: clubs {IDRegion} "! !FeWork subclass: #FeClub instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-nkernel'! FeClub comment: 'A persistent Club on the Server.'! (FeClub getOrMakeCxxClassDescription) friends: '/* friends for class FeClub */ friend class BeClub; '; attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !FeClub methodsFor: 'signing'! {void CLIENT} removeSignatureClub "Essential. Irrevocably remove signature authority for this Club. Requires ownership authority." (CurrentKeyMaster fluidGet hasAuthority: self owner) ifFalse: [Heaper BLAST: #MustBeOwner]. self beClub setSignatureClub: NULL! {void CLIENT} setSignatureClub: club {ID | NULL} "Essential. Change who has signature authority for this Club. Requires ownership authority. Aborts if the Work doesn't have a signature Club." Ravi knownBug. "need to updateStatus on Works which are designating me as Author" club == NULL ifTrue: [Heaper BLAST: #MustNotBeNull]. (CurrentKeyMaster fluidGet hasAuthority: self owner) ifFalse: [Heaper BLAST: #MustBeOwner]. self beClub fetchSignatureClub == NULL ifTrue: [Heaper BLAST: #SignatureClubIrrevocablyRemoved]. self beClub setSignatureClub: club! {ID CLIENT} signatureClub "Essential. The Club which has 'signature authority' for this Club. Members of this Club are allowed to endorse with the ID of this Club, and are allowed to use it to sponsor resources. BLASTs if it has been removed" | result {ID} | result := self beClub fetchSignatureClub. result == NULL ifTrue: [Heaper BLAST: #SignatureClubIrrevocablyRemoved]. ^result! ! !FeClub methodsFor: 'server'! {BeClub} beClub ^self fetchBe cast: BeClub! ! !FeClub methodsFor: 'smalltalk: defaults'! {FeEdition CLIENT} sponsoredWorks ^self sponsoredWorks: NULL! ! !FeClub methodsFor: 'managing storage'! {FeEdition CLIENT} sponsoredWorks: filter {Filter default: NULL} "Essential. All of the Works sponsored by this Club. If a Filter is given, then restricts the result to Works which pass the filter. The result can be wrapped with a Set. This does not require any permissions." | iDSpace {IDSpace} array {PtrArray of: FeWork} index {Int32} | ImmuSet USES. array := PtrArray nulls: self beClub sponsored count DOTasLong. index := Int32Zero. self beClub sponsored stepper forEach: [ :be {BeWork} | (filter == NULL or: [filter match: be endorsements]) ifTrue: [array at: index store: (FeWork on: be). index := index + 1]]. iDSpace := IDSpace unique. index < array count ifTrue: [array := (array copy: index) cast: PtrArray]. ^FeEdition on: (CurrentGrandMap fluidGet newValueEdition: array with: (iDSpace newIDs: array count) with: iDSpace getAscending)! ! !FeClub methodsFor: 'private: create'! create: be {BeClub} super create: be.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FeClub class instanceVariableNames: ''! (FeClub getOrMakeCxxClassDescription) friends: '/* friends for class FeClub */ friend class BeClub; '; attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !FeClub class methodsFor: 'creation'! {FeClub CLIENT} make: status {FeEdition} "Essential. Create a new Club whose initial status is described in the given ClubDescription Edition. The reader, editor and owner are taken from the current settings. If the KeyMaster has edit permission, then the Club Work is initially grabbed by it. The Club Work is initially sponsored by the CurrentSponsor. Note: Unlike ordinary Works, a newly created Club is assigned a global ID." FeKeyMaster assertSponsorship. FeKeyMaster assertSignatureAuthority. ^(CurrentGrandMap fluidGet newClub: status) makeLockedFeWork cast: FeClub! {FeClub} on: be {BeClub} | result {FeClub} | result := self create: be. be addFeRangeElement: result. ^result! ! !FeClub class methodsFor: 'smalltalk: system'! info.stProtocol "{void CLIENT} removeSignatureClub {void CLIENT} setSignatureClub: club {ID} {ID CLIENT} signatureClub {FeEdition CLIENT} sponsoredWorks: filter {Filter default: NULL} "! !Heaper subclass: #FeServer instanceVariableNames: ' myEncrypterName {Sequence} myEncrypter {Encrypter}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-nkernel'! FeServer comment: 'The fundamental Server object. Used for managing the global name space, creating Works, Editions, and Clubs, and other general server management operations. Many operations in the protocol use fluidly bound parameters. The possible parameters are: FeServer defineClientFluid: #CurrentServer with: Listener emulsion with: [NULL]. CurrentKeyMaster - a KeyMaster for providing authority to read and/or edit CurrentAuthor - the ID of the Club under whose name Work revisions are being done; requires signature authority InitialReadClub - the ID of the initial read Club of all newly created Works and Clubs InitialEditClub - the ID of the initial edit Club of all newly created Works and Clubs InitialOwner - the ID of the Club which owns newly created RangeElements InitialSponsor - the ID of the Club which sponsors newly created Works and Clubs; requires signature authority'! (FeServer getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #ON.CLIENT; add: #EQ; yourself)! !FeServer methodsFor: 'miscellaneous'! {PrimPointerSpec} pointerSpec "Essential. A specification for arrays of pointers." ^PrimSpec pointer! ! !FeServer methodsFor: 'create'! create: encrypterName {Sequence} with: encrypter {Encrypter} super create. myEncrypterName _ encrypterName. myEncrypter _ encrypter! ! !FeServer methodsFor: 'security'! {Encrypter} encrypter "Return the Encrypter used for sending sensitive parameters to the Server. (e.g. MatchLock::encryptedPassword ())" ^myEncrypter! {Sequence} getEncrypterName "Essential. The encryption scheme to be used for sending sensitive parameters to the Server. (e.g. MatchLock::encryptedPassword ())" ^myEncrypterName! ! !FeServer methodsFor: 'smalltalk: defaults'! {FeClubDescription} newClubDescription: membership {(FeSet of: FeClub) | NULL} ^self newClubDescription: membership with: NULL! ! !FeServer methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FeServer class instanceVariableNames: ''! (FeServer getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #ON.CLIENT; add: #EQ; yourself)! !FeServer class methodsFor: 'smalltalk: init'! cleanupGarbage self linkTimeNonInherited! exitTimeNonInherited CurrentServer fluidSet: NULL! linkTimeNonInherited Recipe star defineGlobal: #FebeCuisine with: NULL.! staticTimeNonInherited FeServer defineFluid: #CurrentServer with: ServerChunk emulsion with: [NULL]. FeKeyMaster defineFluid: #CurrentKeyMaster with: ServerChunk emulsion with: [NULL]. ID defineFluid: #CurrentAuthor with: ServerChunk emulsion with: [NULL]. ID defineFluid: #InitialReadClub with: ServerChunk emulsion with: [NULL]. ID defineFluid: #InitialEditClub with: ServerChunk emulsion with: [NULL]. ID defineFluid: #InitialOwner with: ServerChunk emulsion with: [NULL]. ID defineFluid: #InitialSponsor with: ServerChunk emulsion with: [NULL].! ! !FeServer class methodsFor: 'smalltalk: defaults'! {ID CLIENT} assignID: range {FeRangeElement} "Essential. Assign a new global ID to a RangeElement. If NULL, then a new unique ID is generated for it, and this requires no permissions. If an ID is supplied, the CurrentKeyMaster must have been granted authority to assign this ID by the Adminer. Returns the newly assigned ID." ^self assignID: range with: NULL! ! !FeServer class methodsFor: 'smalltalk: passe'! {FeServer} current "The Server object for the current connection to Xanadu" "All messages should now be static, or go through the fluid variable." self passe! {ID} nullClubID self passe "emptyClubID"! ! !FeServer class methodsFor: 'server library'! {ID} clubID: clubName {Sequence} "Looks up the ID of a named Club in the directory maintained by the System Admin Club. Requires read permission on the directory. Blasts if there is no Club with that name." ^FeServer iDOf: (((FeServer get: FeServer clubDirectoryID) cast: FeWork) edition get: clubName)! {Sequence} clubName: iD {ID} "Finds the name of a Club in the global directory maintained by the System Admin Club. Blasts if there is no name for that Club, or if there is more than one. Requires read permission on the clubDirectory Work" | club {FeWork} | club := (FeServer get: iD) cast: FeClub. ^(((FeServer get: FeServer clubDirectoryID) cast: FeWork) edition keysOf: club) theOne cast: Sequence! {SequenceRegion} clubNames "The names of all global Clubs. Requires read permission on the clubDirectory Work" ^((FeServer get: FeServer clubDirectoryID) cast: FeWork) edition domain cast: SequenceRegion! {void} disableAccess: clubID {ID} "Disable login access to a Club, by revoking its direct membership of the System Access Club" | club {FeClub} desc {FeClubDescription} | Ravi thingToDo. "kill outstanding KeyMasters" club := (FeServer get: FeServer accessClubID) cast: FeClub. desc := (FeClubDescription spec wrap: club edition) cast: FeClubDescription. club grab. club revise: (desc withMembership: (desc membership without: ((FeServer get: clubID) cast: FeClub))) edition. club release! {void} enableAccess: clubID {ID} "Enable login access to a Club, by listing it as a direct member of the System Access Club" | club {FeClub} desc {FeClubDescription} | club := (FeServer get: FeServer accessClubID) cast: FeClub. desc := (FeClubDescription spec wrap: club edition) cast: FeClubDescription. club grab. club revise: (desc withMembership: (desc membership with: ((FeServer get: clubID) cast: FeClub))) edition. club release! {FilterSpace} endorsementFilterSpace "The CoordinateSpace used for filtering endorsements on this Server. Equivalent to this->filterSpace (this->endorsementSpace ())" self thingToDo. "This should go in CrossSpace" ^CurrentGrandMap fluidGet endorsementFilterSpace! {CrossRegion of: IDRegion and: IDRegion} endorsementRegion: clubs {IDRegion | NULL} with: tokens {IDRegion | NULL} "A set of endorsements for each Club endorsing with each token" self thingToDo. "This should go in CrossSpace" ^FeServer endorsementSpace crossOfRegions: ((PrimSpec pointer arrayWithTwo: clubs with: tokens) cast: PtrArray)! {CrossSpace of: IDSpace and: IDSpace} endorsementSpace "A set of endorsements for each Club endorsing with each token" self thingToDo. "This should go in CrossSpace" ^CurrentGrandMap fluidGet endorsementSpace! {FeWork} globalClubs "The Work mapping names to global Club Works" ^(FeServer get: FeServer clubDirectoryID) cast: FeWork! {BooleanVar} isAdmitted "Return true if the current session has successfully logged into the Server yet." [Dean thingToDo] translateOnly. ^true! {void} nameClub: clubName {Sequence} with: clubID {ID} "Add a Club to the global list of club names. Blasts if there is already a Club by that name." | clubNames {FeWork} club {FeWork} | clubNames := FeServer globalClubs. clubNames grab. [(clubNames edition includesKey: clubName) ifTrue: [Heaper BLAST: #ClubNameInUse]. club := (FeServer get: clubID) cast: FeClub. (clubNames edition keysOf: club) isEmpty ifFalse: [Heaper BLAST: #ClubAlreadyNamed]. clubNames revise: (clubNames edition with: clubName with: club)] valueNowOrOnUnwindDo: (FeWork bomb.ReleaseWork: clubNames)! {void} renameClub: oldName {Sequence} with: newName {Sequence} "Changes the name of an existing Club. Blasts if there is no Club with the old name, or there already is a Club with the new name." | names {FeWork} | names := FeServer globalClubs. names grab. [(names edition includesKey: oldName) ifFalse: [Heaper BLAST: #NoSuchClub]. (names edition includesKey: newName) ifTrue: [Heaper BLAST: #ClubNameInUse]. names revise: ((names edition without: oldName) with: newName with: (names edition get: oldName))] valueNowOrOnUnwindDo: (FeWork bomb.ReleaseWork: names)! {void} unnameClub: clubName {Sequence} "Removes a naming for a Club. Blasts if there is no Club by that clubName." | clubNames {FeWork} | clubNames := FeServer globalClubs. clubNames grab. [(clubNames edition includesKey: clubName) ifTrue: [Heaper BLAST: #NoSuchClub]. clubNames revise: (clubNames edition without: clubName)] valueNowOrOnUnwindDo: (FeWork bomb.ReleaseWork: clubNames)! ! !FeServer class methodsFor: 'create'! {FeServer} implicitReceiver "Get the receiver for wire requests." ^CurrentServer fluidGet! make | encrypter {Encrypter} result {FeServer} | Ravi thingToDo. "use a real Encrypter" Ravi hack. "to force wrappers to be initialized" FeWrapperSpec get: (Sequence string: 'Wrapper'). encrypter := Encrypter make: (Sequence string: 'NoEncrypter'). encrypter randomizeKeys: (UInt8Array string: 'hello'). result _ self create: (Sequence string: 'NoEncrypter') with: encrypter. CurrentServer fluidSet: result. ^CurrentServer fluidGet! ! !FeServer class methodsFor: 'smalltalk: system'! info.stProtocol "{ID CLIENT} accessClubID {ID CLIENT} adminClubID {FeAdminer CLIENT} adminer {ID CLIENT} archiveClubID {FeArchiver CLIENT} archiver {ID CLIENT} assignID: range {FeRangeElement} with: iD {ID default: NULL} {ID CLIENT} clubDirectoryID {CrossSpace CLIENT} crossSpace: subSpaces {PtrArray of: CoordinateSpace} {IntegerVar CLIENT} currentTime {FilterSpace CLIENT} endorsementFilterSpace {CrossRegion CLIENT of: IDRegion and: IDRegion} endorsementRegion: clubs {IDRegion | NULL} with: tokens {IDRegion | NULL} {CrossSpace CLIENT of: IDSpace and: IDSpace} endorsementSpace {FilterSpace CLIENT} filterSpace: baseSpace {CoordinateSpace} {FeRangeElement CLIENT} get: iD {ID} {Sequence CLIENT} identifier {ID CLIENT} iDOf: value {FeRangeElement} {IDRegion CLIENT} iDsOf: value {FeRangeElement} {IDRegion CLIENT} iDsOfRange: edition {FeEdition} {PrimFloatSpec CLIENT} iEEESpec: precision {Int32} {ID CLIENT} importID: data {UInt8Array} {IDRegion CLIENT} importIDRegion: data {UInt8Array} {IDSpace CLIENT} importIDSpace: data {UInt8Array} {IntegerSpace CLIENT} integerSpace {FeBooLockSmith CLIENT} newBooLockSmith {FeChallengeLockSmith CLIENT} newChallengeLockSmith: publicKey {UInt8Array} with: encrypterName {PrimIntegerArray} {FeClub CLIENT} newClub: description {FeEdition} {FeClubDescription CLIENT} newClubDescription: membership {(FeSet of: FeClub) | NULL} with: lockSmith {FeLockSmith default: NULL} {FeClubDescription CLIENT} newClubDescription: members {FeWorkSet} with: lockSmith {FeLockSmith} with: home {FeWork | NULL} {FeDataHolder CLIENT} newDataHolder: value {PrimValue} {FeEdition CLIENT} newEdition: values {PrimArray of: FeRangeElement} with: positions {XuRegion default: NULL} with: ordering {OrderSpec default: NULL} {FeEdition CLIENT} newEditionWith: position {Position} with: value {FeRangeElement} {FeEdition CLIENT} newEditionWithAll: domain {XuRegion} with: value {FeRangeElement} {FeEdition CLIENT} newEmptyEdition: cs {CoordinateSpace} {FeHyperLink CLIENT} newHyperLink: types {(FeSet of: FeWork) default: NULL} with: leftEnd {FeHyperRef default: NULL} with: rightEnd {FeHyperRef default: NULL} {ID CLIENT} newID {FeIDHolder CLIENT} newIDHolder: iD {ID} {IDSpace CLIENT} newIDSpace {FeLabel CLIENT} newLabel {FeMatchLockSmith CLIENT} newMatchLockSmith: scrambledPassword {UInt8Array} with: scramblerName {PrimIntegerArray} {FeMultiLockSmith CLIENT} newMultiLockSmith {FeMultiRef CLIENT} newMultiRef: refs {(PtrArray of: FeHyperRef) default: NULL} with: workContext {FeWork default: NULL} with: originalContext {FeWork default: NULL} with: pathContext {FePath default: NULL} {FePath CLIENT} newPath: labels {(PtrArray of: FeLabel) default: NULL} {FeRangeElement CLIENT} newPlaceHolder {FeEdition CLIENT} newPlaceHolders: domain {XuRegion} {FeSet CLIENT} newSet: values {(PtrArray of: FeRangeElement) default: NULL} {FeSingleRef CLIENT} newSingleRef: excerpt {FeEdition | NULL} with: workContext {FeWork default: NULL} with: originalContext {FeWork default: NULL} with: pathContext {FePath default: NULL} {FeText CLIENT} newText: data {PrimArray.X default: NULL} {FeWallLockSmith CLIENT} newWallLockSmith {FeWork CLIENT} newWork: contents {FeEdition} {ID CLIENT} nullClubID {PrimPointerSpec CLIENT} pointerSpec {ID CLIENT} publicClubID {FeKeyMaster CLIENT} publicKeyMaster {RealSpace CLIENT} realSpace {FeSession CLIENT} session {void CLIENT} waitForConsequences: detector {PrWaitDetector} {void CLIENT} waitForWrite: detector {PrWaitDetector} {FeWrapperSpec CLIENT} wrapperSpec: name {Sequence} "! ! !FeServer class methodsFor: 'managing clubs'! {ID CLIENT} accessClubID "Essential. The ID of the System Access Club." ^CurrentGrandMap fluidGet accessClubID! {ID CLIENT} adminClubID "Essential. The ID of the System Admin Club." ^CurrentGrandMap fluidGet adminClubID! {ID CLIENT} archiveClubID "Essential. The ID of the System Archive Club." self knownBug. "logging into this Club does not actually give you full read/edit authority" ^CurrentGrandMap fluidGet archiveClubID! {ID CLIENT} emptyClubID "Essential. The ID of the Universal Empty Club." ^CurrentGrandMap fluidGet emptyClubID! {Sequence CLIENT login} encrypterName "Essential. The encryption scheme to be used for sending sensitive parameters to the Server. (e.g. MatchLock::encryptedPassword ())" ^CurrentServer fluidGet getEncrypterName! {Lock CLIENT login} login: clubID {ID} "Essential. Return a lock which, if satisfied, will give a KeyMaster logged in to that Club. It will be able to exercise the authority of all of its superClubs. The club must be in the System Access Club or another club must have been logged in during this session. If that doesn't hold, or there is no such club, returns the gateLockSpec chosen by the Administrator if there is no such Club" | club {BeClub} cgm {BeGrandMap} | Ravi thingToDo. "Check this please." cgm := CurrentGrandMap fluidGet. club _ cgm fetchClub: clubID. (club ~~ NULL and: [FeSession current isLoggedIn or: [(cgm getClub: FeServer accessClubID) membershipIncludes: club]]) ifTrue: [^((FeClubDescription spec wrap: club edition) cast: FeClubDescription) lockSmith newLock: clubID] ifFalse: [^FeServer gateLockSmith newLock: NULL]! {Lock CLIENT login} loginByName: clubName {Sequence} "Essential. Return a lock which, if satisfied, will give a KeyMaster logged in to the named Club. It will be able to exercise the authority of all of its superClubs. The club must be in the System Access Club or another club must have been logged in during this session. If that doesn't hold, or there is no such club, returns the gateLockSpec chosen by the Administrator if there is no such Club" | club {BeClub} cgm {BeGrandMap} | Ravi thingToDo. "Check this please." cgm := CurrentGrandMap fluidGet. (((cgm get: cgm clubDirectoryID) cast: BeWork) edition fetch: clubName) cast: FeClub into: [:feclub | club _ feclub beClub] others: [club _ NULL]. (club ~~ NULL and: [FeSession current isLoggedIn or: [(cgm getClub: FeServer accessClubID) membershipIncludes: club]]) ifTrue: [^((FeClubDescription spec wrap: club edition) cast: FeClubDescription) lockSmith newLock: (cgm iDOf: club)] ifFalse: [^FeServer gateLockSmith newLock: NULL]! {ID CLIENT} publicClubID "Essential. The ID of the Universal Public Club." ^CurrentGrandMap fluidGet publicClubID! {UInt8Array CLIENT login} publicKey "Essential. The public key to be used for sending sensitive parameters to the Server. (e.g. MatchLock::encryptedPassword ())" ^CurrentServer fluidGet encrypter publicKey! ! !FeServer class methodsFor: 'comm requests'! {NOACK CLIENT login} force "Flush the Server's output buffers." Dean shouldImplement! {NOACK CLIENT} setCurrentAuthor: iD {ID} "Set the Server side fluid for the CurrentAuthor." CurrentAuthor fluidSet: iD! {NOACK CLIENT} setCurrentKeyMaster: km {FeKeyMaster} "Set the Server side fluid for the CurrentKeyMaster." CurrentKeyMaster fluidSet: km! {NOACK CLIENT} setInitialEditClub: iD {ID} "Set the Server side fluid for the InitialEditClub." InitialEditClub fluidSet: iD! {NOACK CLIENT} setInitialOwner: iD {ID} "Set the Server side fluid for the InitialOwner." InitialOwner fluidSet: iD! {NOACK CLIENT} setInitialReadClub: iD {ID} "Set the Server side fluid for the InitialReadClub." InitialReadClub fluidSet: iD! {NOACK CLIENT} setInitialSponsor: iD {ID} "Set the Server side fluid for the InitialSponsor." InitialSponsor fluidSet: iD! ! !FeServer class methodsFor: 'global ids'! {ID CLIENT} assignID: range {FeRangeElement} with: iD {ID default: NULL} "Essential. Assign a new global ID to a RangeElement. If NULL, then a new unique ID is generated for it, and this requires no permissions. If an ID is supplied, the CurrentKeyMaster must have been granted authority to assign this ID by the Adminer. Returns the newly assigned ID." | gm {BeGrandMap} | gm _ CurrentGrandMap fluidGet. iD == NULL ifTrue: [^gm assignID: range getOrMakeBe]. (CurrentKeyMaster fluidGet hasAuthority: (gm grantAt: iD)) ifFalse: [Heaper BLAST: #MustHaveBeenGrantedAuthority]. (gm at: iD tryIntroduce: range getOrMakeBe) ifFalse: [Heaper BLAST: #IDAlreadyAssigned]. ^iD! {ID CLIENT} clubDirectoryID "The ID of a Work mapping Club names to FeClubs" ^CurrentGrandMap fluidGet clubDirectoryID! {FeRangeElement CLIENT} get: iD {ID} "Essential. Get the object associated with the given global ID. Typically, it will be a Work. Blast if there is nothing there" ^CurrentGrandMap fluidGet getFe: iD! {ID CLIENT} iDOf: value {FeRangeElement} "Find the unique global ID on this Server that has been assigned to this RangeElement. Blast if there is none, or more than one. Equivalent to CAST(ID, this->iDsOf (value)->theOne ())" | be {BeRangeElement} | be := value fetchBe. be == NULL ifTrue: [Heaper BLAST: #DoesNotHaveAnID. ^NULL] ifFalse: [^CurrentGrandMap fluidGet iDOf: be]! {IDRegion CLIENT} iDsOf: value {FeRangeElement} "Essential. Find all the global IDs on this Server that have been assigned to this RangeElement" | be {BeRangeElement} | be := value fetchBe. be == NULL ifTrue: [^(IDSpace global emptyRegion cast: IDRegion)] ifFalse: [^CurrentGrandMap fluidGet iDsOf: be]! {IDRegion CLIENT} iDsOfRange: edition {FeEdition} "Find all the global IDs on this Server that have been assigned to any of the RangeElements in an Edition" | result {XnRegion} | self thingToDo. "fix this grossly inefficient algorithm so that at least it doesn't check every single virtual object in the range" edition isFinite ifFalse: [Heaper BLAST: #MustBeFinite]. result := IDSpace global emptyRegion. edition stepper forEach: [ :value {FeRangeElement} | | be {BeRangeElement} | be := value fetchBe. be ~~ NULL ifTrue: [result := result unionWith: (CurrentGrandMap fluidGet iDsOf: be)]]. ^result cast: IDRegion! ! !FeServer class methodsFor: 'accessing'! {IntegerVar CLIENT} currentTime "The current clock time on the Server, in seconds since the 'beginning of time'" ^Time xuTime! {FeLockSmith} gateLockSmith "The LockSmith which hands out locks when a client tries to login through the GateKeeper with an invalid Club ID or name." ^(FeLockSmith spec wrap: CurrentGrandMap fluidGet gateLockSmithEdition) cast: FeLockSmith! {Sequence CLIENT} identifier "Essential. A sequence of numbers uniquely identifying this Server" ^CurrentGrandMap fluidGet identifier! {void} removeWaitDetector: detector {FeWaitDetector} "This is currently a no-op."! {FeWaitDetector CLIENT} waitForConsequences "Essential. The Detector will be triggered when the consequences of all previous local requests have finished propagating through this Server. (e.g. Edition::transclusions may take a while to collect all of the results.) If you want to remove the Detector before it is triggered, destroy it. Note that this is NOT a request to speed up the completion of the outstanding requests. See WaitDetector::done ()" MarkM shouldImplement. FeServer waitForConsequences: NULL. ^NULL "fodder"! {void} waitForConsequences: detector {FeWaitDetector} "Essential. The Detector will be triggered when the consequences of all previous local requests have finished propagating through this Server. (e.g. Edition::transclusions may take a while to collect all of the results.) If you want to remove the Detector before it is triggered, destroy it. Note that this is NOT a request to speed up the completion of the outstanding requests. See WaitDetector::done ()" MarkM shouldImplement! {FeWaitDetector CLIENT} waitForWrite "Essential. The Detector will be triggered when the current state of the Server has been reliably written to disk. If you want to remove the Detector before it is triggered, destroy it. See WaitDetector::done ()" Dean shouldImplement. FeServer waitForWrite: NULL. ^NULL "fodder"! {void} waitForWrite: detector {FeWaitDetector} "Essential. The Detector will be triggered when the current state of the Server has been reliably written to disk. If you want to remove the Detector before it is triggered, destroy it. See WaitDetector::done ()" [DiskManager] USES. CurrentPacker fluidGet purge. detector done! !Heaper subclass: #FeSession instanceVariableNames: ' myInitialLogin {ID | NULL} myConnectTime {IntegerVar}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-nadmin'! FeSession comment: 'Represent a single unique connection to the server over some underlying bytestream channel.'! (FeSession getOrMakeCxxClassDescription) friends: 'friend class Lock; '; attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !FeSession methodsFor: 'accessing'! {IntegerVar CLIENT} connectTime "Essential. The clock time at which the connection was initiated." ^myConnectTime! {void CLIENT} endSession: withPrejudice {BooleanVar default: false} "Essential. Terminate this connection. If withPrejudice is false, it completes the current request and flushes all output before disconnecting." self subclassResponsibility! {ID CLIENT} initialLogin "Essential. The ID of the club that the session logged into to get past the perimeter. Blast of the session is not yet admitted." myInitialLogin == NULL ifTrue: [Heaper BLAST: #NotLoggedIn]. ^myInitialLogin! {BooleanVar CLIENT} isConnected "Return whether the session has sucessfully logged in, and is still logged in." self subclassResponsibility! {BooleanVar} isLoggedIn "Return whether the session has sucessfully logged in." ^myInitialLogin ~~ NULL! {UInt8Array CLIENT} port "Essential. A system-specific description of the actual transport medium over which the connection is being maintained." self subclassResponsibility! ! !FeSession methodsFor: 'smalltalk: defaults'! {void CLIENT} endSession "Essential. Gracefully terminate this connection" self endSession: false! ! !FeSession methodsFor: 'creation'! create super create. myInitialLogin _ NULL. myConnectTime _ FeServer currentTime. CurrentSession fluidSet: self! ! !FeSession methodsFor: 'private: accessing'! {void} setInitialLogin: iD {ID} "Set the ID of the Club which initially logged in during this session" (myInitialLogin == NULL) assert. myInitialLogin := iD.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FeSession class instanceVariableNames: ''! (FeSession getOrMakeCxxClassDescription) friends: 'friend class Lock; '; attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !FeSession class methodsFor: 'smalltalk: system'! info.stProtocol "{IntegerVar CLIENT} connectTime {void CLIENT} disconnect {IDRegion CLIENT} initialLogins {PrimIntegerArray CLIENT} port "! ! !FeSession class methodsFor: 'accessing'! {Stepper of: FeSession} allActive "CurrentSessions fluidFetch == NULL ifTrue: [^Stepper itemStepper: CurrentSession fluidGet] ifFalse: [| acc {SetAccumulator} cur {FePromiseSession} | acc _ SetAccumulator make. cur _ CurrentSessions fluidGet. [cur ~~ NULL] whileTrue: [acc step: cur. cur _ cur next]. ^(acc value cast: ScruSet) stepper]" ^ ImmuSet make stepper! {FeSession CLIENT} current ^CurrentSession fluidGet! ! !FeSession class methodsFor: 'smalltalk: init'! staticTimeNonInherited FeSession defineFluid: #CurrentSession with: ServerChunk emulsion with: [DefaultSession make].! !FeSession subclass: #DefaultSession instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-nadmin'! DefaultSession comment: 'The default session.'! (DefaultSession getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !DefaultSession methodsFor: 'accessing'! {void CLIENT} endSession: withPrejudice {BooleanVar default: false} "Do nothing"! {BooleanVar} isConnected "Return whether the session has sucessfully logged in." ^true! {UInt8Array CLIENT} port "Essential. A system-specific description of the actual transport medium over which the connection is being maintained." ^UInt8Array string: 'default'! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DefaultSession class instanceVariableNames: ''! (DefaultSession getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !DefaultSession class methodsFor: 'creation'! {FeSession} make ^self create! !FeSession subclass: #FePromiseSession instanceVariableNames: ' myPort {UInt8Array} myManager {PromiseManager} myListener {Heaper} myNext {FePromiseSession | NULL}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-nadmin'! FePromiseSession comment: 'Represent a single unique connection to the server over some underlying bytestream channel.'! (FePromiseSession getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !FePromiseSession methodsFor: 'accessing'! {void CLIENT} endSession: withPrejudice {BooleanVar default: false} "Essential. Terminate this connection. If withPrejudice is false, it completes the current request and flushes all output before disconnecting." withPrejudice ifFalse: [myManager force]. myManager _ NULL. myListener destroy. myListener _ NULL. (CurrentSessions fluidGet basicCast: Heaper star) == self ifTrue: [CurrentSessions fluidSet: self next] ifFalse: [CurrentSessions fluidGet remove: self]! {BooleanVar} isConnected "Return whether the session has sucessfully logged in." ^myManager ~~ NULL! {FePromiseSession | NULL} next ^myNext! {UInt8Array CLIENT} port "Essential. A system-specific description of the actual transport medium over which the connection is being maintained." ^myPort! {void} remove: session {FePromiseSession} myNext ~~ NULL ifTrue: [(myNext isEqual: session) ifTrue: [myNext _ session next] ifFalse: [myNext remove: session]]! ! !FePromiseSession methodsFor: 'creation'! create: port {UInt8Array} with: listener {Heaper} with: manager {PromiseManager} super create. myPort _ port. myManager _ manager. myListener _ listener. myNext _ CurrentSessions fluidFetch. CurrentSessions fluidSet: self.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FePromiseSession class instanceVariableNames: ''! (FePromiseSession getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !FePromiseSession class methodsFor: 'smalltalk: init'! staticTimeNonInherited FePromiseSession defineFluid: #CurrentSessions with: DiskManager emulsion with: [NULL].! ! !FePromiseSession class methodsFor: 'ceration'! make: port {UInt8Array} with: listener {Heaper} with: manager {PromiseManager} ^FePromiseSession create: port with: listener with: manager! !Heaper subclass: #FeWrapper instanceVariableNames: ' myEdition {FeEdition} myInner {FeWrapper | NULL} mySpec {FeWrapperSpec}' classVariableNames: 'TheWrapperSpec {FeWrapperSpec} ' poolDictionaries: '' category: 'Xanadu-wrapper'! FeWrapper comment: 'An object which wraps an Edition, providing additional functionality for manipulating it and enforcing invariants on the format. Implementation note: The fact that you cannot get the spec of a Wrapper is deliberate. You can merely check that it is a kind of Edition you know, but no more; this makes it easy to compatibly add new leaf classes below existing ones.'! (FeWrapper getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; add: #EQ; yourself)! !FeWrapper methodsFor: 'accessing'! {FeEdition CLIENT} edition "Essential. The primitive Edition this is wrapping." ^myEdition! {FeWrapper CLIENT} inner "Essential. The next Wrapper inside this one; blasts if this wraps an Edition directly." myInner == NULL ifTrue: [Heaper BLAST: #NoInnerWrapper]. ^myInner! {BooleanVar} isWrapperOf: spec {FeWrapperSpec} "Essential. Return TRUE if this is wrapped as the given spec, or any one of its subtypes" ^mySpec isSubSpecOf: spec! ! !FeWrapper methodsFor: 'protected: create'! create: edition {FeEdition} with: spec {FeWrapperSpec} super create. myEdition := edition. myInner := NULL. mySpec := spec.! create: edition {FeEdition} with: inner {FeWrapper} with: spec {FeWrapperSpec} super create. myEdition := edition. myInner := inner. mySpec := spec.! ! !FeWrapper methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FeWrapper class instanceVariableNames: ''! (FeWrapper getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; add: #EQ; yourself)! !FeWrapper class methodsFor: 'smalltalk: initialization'! initTimeNonInherited FeWrapperSpec ABSTRACTWRAPPER: 'Wrapper' with: NULL with: #FeWrapper! linkTimeNonInherited TheWrapperSpec := NULL.! ! !FeWrapper class methodsFor: 'private: wrapping'! {void} setSpec: spec {FeWrapperSpec} TheWrapperSpec := spec.! ! !FeWrapper class methodsFor: 'accessing'! {FeWrapperSpec} spec ^TheWrapperSpec! ! !FeWrapper class methodsFor: 'protected: checking'! {BooleanVar} checkDomainHas: edition {FeEdition} with: required {XnRegion} "Checks that the domain is in the right coordinate space and is a superset of the given region" ^(edition coordinateSpace isEqual: required coordinateSpace) and: [required isSubsetOf: edition domain]! {BooleanVar} checkDomainIn: edition {FeEdition} with: limit {XnRegion} "Checks that the domain is in the right coordinate space and a subset of the given region" ^(edition coordinateSpace isEqual: limit coordinateSpace) and: [edition domain isSubsetOf: limit]! {BooleanVar} checkSubEdition: parent {FeEdition} with: key {Position} with: spec {FeWrapperSpec | NULL} with: required {BooleanVar} "If there is a SubEdition at a key in an edition, and if a spec is supplied, that it can be certified as the given type" | value {FeRangeElement} | value := parent fetch: key. value == NULL ifTrue: [^required not]. ^(value isKindOf: FeEdition) and: [spec == NULL or: [spec certify: (value cast: FeEdition)]]! {BooleanVar} checkSubEditions: parent {FeEdition} with: keys {XnRegion} with: spec {FeWrapperSpec} with: required {BooleanVar} "Check that everything in the region is an Edition, which can be certified with the given type" keys stepper forEach: [ :key {Position} | (self checkSubEdition: parent with: key with: spec with: required) ifFalse: [^false]]. ^true! {BooleanVar} checkSubSequence: edition {FeEdition} with: key {Position} with: required {BooleanVar} "Whether there is an Edition there which can be successfully converted into a zero based Sequence" | value {FeRangeElement} | Ravi hack. "zones" value := edition fetch: key. value == NULL ifTrue: [^required not]. ^(value isKindOf: FeEdition) and: [((value cast: FeEdition) coordinateSpace isEqual: IntegerSpace make) and: [((value cast: FeEdition) domain cast: IntegerRegion) isCompacted "and: [((value cast: FeEdition) zoneOf: PrimSpec uInt8) domain isEqual: (value cast: FeEdition) domain]"]]! {BooleanVar} checkSubWork: parent {FeEdition} with: key {Position} with: required {BooleanVar} "If there is a SubWork at a key in an edition" | value {FeRangeElement} | value := parent fetch: key. value == NULL ifTrue: [^required not]. ^value ~~ NULL and: [value isKindOf: FeWork]! ! !FeWrapper class methodsFor: 'smalltalk: passe'! {BooleanVar} checkSubSetEdition: parent {FeEdition} with: key {Position} with: spec {FeWrapperSpec | NULL} with: required {BooleanVar} "If there is a SubEdition at a key in an edition, that it can be wrapped as a Set, and if a spec is supplied, that it only contains the given type" | value {FeRangeElement} set {FeSet} | self passe. value := parent fetch: key. value == NULL ifTrue: [^required not]. ((value isKindOf: FeEdition) and: [FeSet spec certify: (value cast: FeEdition)]) ifFalse: [^false]. set := (FeSet spec wrap: (value cast: FeEdition)) cast: FeSet. ^spec == NULL or: [set count = (set count: spec)]! ! !FeWrapper class methodsFor: 'smalltalk: system'! info.stProtocol "{FeEdition CLIENT} edition {FeWrapper CLIENT} inner {BooleanVar CLIENT} isWrappedAs: spec {FeWrapperSpec} "! !FeWrapper subclass: #FeClubDescription instanceVariableNames: '' classVariableNames: 'TheClubDescriptionSpec {FeWrapperSpec} ' poolDictionaries: '' category: 'Xanadu-nadmin'! FeClubDescription comment: 'Describes the state of Club -- who is in it, which Work is its home (if it has one), and how you can login to it'! (FeClubDescription getOrMakeCxxClassDescription) friends: '/* friends for class FeClubDescription */ friend class BeClub; '; attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !FeClubDescription methodsFor: 'accessing'! {FeLockSmith CLIENT} lockSmith "Describes how authority for this Club is gained" (self edition includesKey: (Sequence string: 'ClubDescription:LockSmith')) ifTrue: [^(FeLockSmith spec wrap: ((self edition get: (Sequence string: 'ClubDescription:LockSmith')) cast: FeEdition)) cast: FeLockSmith] ifFalse: [^FeWallLockSmith make]! {FeSet CLIENT of: FeClub} membership "The Clubs which are members of this one." (self edition includesKey: (Sequence string: 'ClubDescription:Membership')) ifTrue: [^(FeSet spec wrap: ((self edition get: (Sequence string: 'ClubDescription:Membership')) cast: FeEdition)) cast: FeSet] ifFalse: [^FeSet make]! {FeClubDescription CLIENT} withLockSmith: lockSmith {FeLockSmith} "Change how authority is gained" ^FeClubDescription construct: (self edition with: (Sequence string: 'ClubDescription:LockSmith') with: lockSmith edition)! {FeClubDescription CLIENT} withMembership: members {FeSet of: FeClub} "Change the entire membership list" ^FeClubDescription construct: (self edition with: (Sequence string: 'ClubDescription:Membership') with: members edition)! ! !FeClubDescription methodsFor: 'private: create'! create: edition {FeEdition} with: spec {FeWrapperSpec} super create: edition with: spec! ! !FeClubDescription methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '(' << self lockSmith << ', ' << self membership << ')'! ! !FeClubDescription methodsFor: 'smalltalk: passe'! {FeWork} home "The Work which is the home for this Club; blasts if it has none" self passe. ^(self edition get: (Sequence string: 'ClubDescription:Home')) cast: FeWork! {FeClubDescription} withHome: home {FeWork | NULL} "Change the home to different Work, or to none if NULL" self passe. home == NULL ifTrue: [^FeClubDescription construct: (self edition without: (Sequence string: 'ClubDescription:Home'))] ifFalse: [^FeClubDescription construct: (self edition with: (Sequence string: 'ClubDescription:Home') with: home edition)]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FeClubDescription class instanceVariableNames: ''! (FeClubDescription getOrMakeCxxClassDescription) friends: '/* friends for class FeClubDescription */ friend class BeClub; '; attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !FeClubDescription class methodsFor: 'private: wrapping'! {BooleanVar} check: edition {FeEdition} "Check that it has the right fields in the right places. Ignore other contents." ((FeWrapper checkDomainIn: edition with: ((Sequence string: 'ClubDescription:LockSmith') asRegion with: (Sequence string: 'ClubDescription:Membership'))) and: [(FeWrapper checkSubEdition: edition with: (Sequence string: 'ClubDescription:Membership') with: FeSet spec with: false) and: [FeWrapper checkSubEdition: edition with: (Sequence string: 'ClubDescription:LockSmith') with: FeLockSmith spec with: false]]) ifFalse: [^false]. (edition includesKey: (Sequence string: 'ClubDescription:Membership')) ifTrue: [ | sub {FeEdition} | sub := (edition get: (Sequence string: 'ClubDescription:Membership')) cast: FeEdition. sub stepper forEach: [ :r {FeRangeElement} | (r isKindOf: FeClub) ifFalse: [^false]]]. ^true! {FeClubDescription} construct: edition {FeEdition} "Create a new wrapper and endorse it" self spec endorse: edition. ^(self makeWrapper: edition) cast: FeClubDescription! {FeWrapper} makeWrapper: edition {FeEdition} "Just create a new wrapper" ^self create: edition with: self spec! {void} setSpec: wrap {FeWrapperSpec} TheClubDescriptionSpec := wrap.! ! !FeClubDescription class methodsFor: 'smalltalk: init'! initTimeNonInherited FeWrapperSpec DIRECTWRAPPER: 'ClubDescription' with: 'Wrapper' with: #FeClubDescription.! linkTimeNonInherited TheClubDescriptionSpec := NULL.! ! !FeClubDescription class methodsFor: 'pseudo constructors'! {FeClubDescription CLIENT} make: membership {(FeSet of: FeClub) | NULL} with: lockSmith {FeLockSmith default: NULL} | result {FeEdition} | result := FeEdition empty: SequenceSpace make. membership ~~ NULL ifTrue: [result := result with: (Sequence string: 'ClubDescription:Membership') with: membership edition]. lockSmith ~~ NULL ifTrue: [result := result with: (Sequence string: 'ClubDescription:LockSmith') with: lockSmith edition]. ^(self spec wrap: result) cast: FeClubDescription! {FeWrapperSpec} spec ^TheClubDescriptionSpec! ! !FeClubDescription class methodsFor: 'smalltalk: passe'! make: members {FeSet | NULL} with: lockSmith {FeLockSmith | NULL} with: home {FeWork | NULL} | result {FeEdition} | self passe. result := FeEdition empty: SequenceSpace make. members ~~ NULL ifTrue: [result := result with: (Sequence string: 'ClubDescription:Membership') with: members edition]. lockSmith ~~ NULL ifTrue: [result := result with: (Sequence string: 'ClubDescription:LockSmith') with: lockSmith edition]. home ~~ NULL ifTrue: [result := result with: (Sequence string: 'ClubDescription:Home') with: home]. ^(self spec wrap: result) cast: FeClubDescription! ! !FeClubDescription class methodsFor: 'smalltalk: system'! info.stProtocol "{FeLockSmith CLIENT} lockSmith {FeSet CLIENT of: FeClub} membership {FeClubDescription CLIENT} withLockSmith: lockSmith {FeLockSmith} {FeClubDescription CLIENT} withMembership: members {FeSet of: FeClub} "! !FeWrapper subclass: #FeHyperLink instanceVariableNames: '' classVariableNames: 'TheHyperLinkSpec {FeWrapperSpec} ' poolDictionaries: '' category: 'Xanadu-nlinks'! FeHyperLink comment: 'Contains a named table of HyperRefs and a set of Works which describe the usage and/or format of the link.'! (FeHyperLink getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !FeHyperLink methodsFor: 'accessing'! {FeHyperRef CLIENT} endAt: name {Sequence} "Get the HyperRef at the given name; blast if none there" (name isEqual: (Sequence string: 'Link:LinkTypes')) ifTrue: [Heaper BLAST: #MustUseDifferentLinkEndKey]. ^(FeHyperRef spec wrap: ((self edition get: name) cast: FeEdition)) cast: FeHyperRef! {SequenceRegion CLIENT} endNames "The names of all of the ends of this link" ^(self edition domain without: (Sequence string: 'HyperLink:LinkTypes')) cast: SequenceRegion! {FeSet CLIENT of: FeWork} linkTypes "The various type documents describing this kind of Link. These documents are typically Editions with descriptions at each linkEnd key describing what is at that Link End. The reason for having several is to allow type hierarchies to be constructed and searched for, by including all super types of a link in its link type list. The Link should be endorsed with all the IDs of all the types. What if someone endorses it further (or unendorses it?)" ^(FeSet spec wrap: ((self edition get: (Sequence string: 'Link:LinkTypes')) cast: FeEdition)) cast: FeSet! {FeHyperLink CLIENT} withEnd: name {Sequence} with: linkEnd {FeHyperRef} "Change/add a Link end" (name isEqual: (Sequence string: 'Link:LinkTypes')) ifTrue: [Heaper BLAST: #MustUseDifferentLinkEndName]. ^FeHyperLink construct: (self edition with: name with: linkEnd edition)! {FeHyperLink CLIENT} withLinkTypes: types {FeSet of: FeWork} "Replace the set of type documents describing this kind of Link" ^FeHyperLink construct: (self edition with: (Sequence string: 'Link:LinkTypes') with: types edition)! {FeHyperLink CLIENT} withoutEnd: name {Sequence} "Remove a Link end" (name isEqual: (Sequence string: 'Link:LinkTypes')) ifTrue: [Heaper BLAST: #MustUseDifferentLinkEndName]. ^FeHyperLink construct: (self edition without: name)! ! !FeHyperLink methodsFor: 'private: create'! create: edition {FeEdition} with: spec {FeWrapperSpec} super create: edition with: spec! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FeHyperLink class instanceVariableNames: ''! (FeHyperLink getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !FeHyperLink class methodsFor: 'private: wrapping'! {BooleanVar} check: edition {FeEdition} "Check that it has the right fields in the right places. Ignore other contents." ((FeWrapper checkDomainHas: edition with: (Sequence string: 'Link:LinkTypes') asRegion) and: [(FeWrapper checkSubEdition: edition with: (Sequence string: 'Link:LinkTypes') with: FeSet spec with: false) and: [FeWrapper checkSubEditions: edition with: (edition domain without: (Sequence string: 'Link:LinkTypes')) with: FeHyperRef spec with: true]]) ifFalse: [^false]. (edition includesKey: (Sequence string: 'Link:LinkTypes')) ifTrue: [ | sub {FeEdition} | sub := (edition get: (Sequence string: 'Link:LinkTypes')) cast: FeEdition. sub stepper forEach: [ :r {FeRangeElement} | ((r isKindOf: FeEdition) and: [FeHyperRef spec certify: (r cast: FeEdition)]) ifFalse: [^false]]]. ^true! {FeHyperLink} construct: edition {FeEdition} self spec endorse: edition. edition endorse: (FeServer endorsementRegion: (CurrentAuthor fluidGet asRegion cast: IDRegion) with: (FeServer iDsOfRange: ((edition get: (Sequence string: 'Link:LinkTypes')) cast: FeEdition))). ^(self makeWrapper: edition) cast: FeHyperLink! {FeWrapper} makeWrapper: edition {FeEdition} "Just create a new wrapper" ^self create: edition with: self spec! {void} setSpec: wrap {FeWrapperSpec} TheHyperLinkSpec := wrap.! ! !FeHyperLink class methodsFor: 'pseudo constructors'! {Filter} linkFilter: types {IDRegion} "A Filter for links of the specified types" self unimplemented. ^NULL "fodder"! {FeHyperLink CLIENT} make: types {FeSet} with: leftEnd {FeHyperRef} with: rightEnd {FeHyperRef} "Make a standard two-ended link" | values {PtrArray of: FeEdition} | types stepper forEach: [ :t {FeRangeElement} | (t isKindOf: FeWork) ifFalse: [Heaper BLAST: #InvalidParameter]]. values := PtrArray nulls: 3. "Put the values in the array in alphabetical order of keys" values at: Int32Zero store: leftEnd edition. values at: 1 store: types edition. values at: 2 store: rightEnd edition. ^self construct: (FeEdition fromArray: values with: (((Sequence string: 'Link:LinkTypes') asRegion with: (Sequence string: 'Link:LeftEnd')) with: (Sequence string: 'Link:RightEnd')) with: SequenceSpace make getAscending)! {FeWrapperSpec} spec ^TheHyperLinkSpec! ! !FeHyperLink class methodsFor: 'smalltalk: init'! initTimeNonInherited FeWrapperSpec DIRECTWRAPPER: 'HyperLink' with: 'Wrapper' with: #FeHyperLink.! linkTimeNonInherited TheHyperLinkSpec := NULL.! ! !FeHyperLink class methodsFor: 'smalltalk: system'! info.stProtocol "{FeHyperRef CLIENT} endAt: name {Sequence} {SequenceRegion CLIENT} endNames {FeSet CLIENT of: FeWork} linkTypes {FeHyperLink CLIENT} withEnd: name {Sequence} with: linkEnd {FeHyperRef} {FeHyperLink CLIENT} withLinkTypes: types {FeSet of: FeWork} {FeHyperLink CLIENT} withoutEnd: name {Sequence} "! !FeWrapper subclass: #FeHyperRef instanceVariableNames: '' classVariableNames: 'TheHyperRefSpec {FeWrapperSpec} ' poolDictionaries: '' category: 'Xanadu-nlinks'! FeHyperRef comment: 'Represents a single attachment to some material in context.'! (FeHyperRef getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; yourself)! !FeHyperRef methodsFor: 'accessing'! {FeWork CLIENT} originalContext "A Work frozen on the contents of the Work at the time the HyperRef was made" ^(self edition get: (Sequence string: 'HyperRef:OriginalContext')) cast: FeWork! {FePath CLIENT} pathContext "The path of labels down from the top-level Edition" ^(FePath spec wrap: ((self edition get: (Sequence string: 'HyperRef:PathContext')) cast: FeEdition)) cast: FePath! {FeHyperRef CLIENT} withOriginalContext: work {FeWork | NULL} "Change (or remove if NULL) the originalContext" work == NULL ifTrue: [^self makeNew: (self edition without: (Sequence string: 'HyperRef:OriginalContext'))] ifFalse: [(work fetchBe cast: BeWork) fetchEditClub ~~ NULL ifTrue: [Heaper BLAST: #MustBeFrozen]. ^self makeNew: (self edition with: (Sequence string: 'HyperRef:OriginalContext') with: work)]! {FeHyperRef CLIENT} withPathContext: path {FePath | NULL} "Change (or remove if NULL) the pathContext" path == NULL ifTrue: [^self makeNew: (self edition without: (Sequence string: 'HyperRef:PathContext'))] ifFalse: [^self makeNew: (self edition with: (Sequence string: 'HyperRef:PathContext') with: path edition)]! {FeHyperRef CLIENT} withWorkContext: work {FeWork | NULL} "Change (or remove if NULL) the workContext" work == NULL ifTrue: [^self makeNew: (self edition without: (Sequence string: 'HyperRef:WorkContext'))] ifFalse: [^self makeNew: (self edition with: (Sequence string: 'HyperRef:WorkContext') with: work)]! {FeWork CLIENT} workContext "The Work whose state this is attached to." ^(self edition get: (Sequence string: 'HyperRef:WorkContext')) cast: FeWork! ! !FeHyperRef methodsFor: 'protected: create'! create: edition {FeEdition} with: spec {FeWrapperSpec} super create: edition with: spec! {FeHyperRef} makeNew: edition {FeEdition} "Make a new HyperRef of the same type with different contents" self subclassResponsibility! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FeHyperRef class instanceVariableNames: ''! (FeHyperRef getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; yourself)! !FeHyperRef class methodsFor: 'smalltalk: initialization'! initTimeNonInherited FeWrapperSpec ABSTRACTWRAPPER: 'HyperRef' with: 'Wrapper' with: #FeHyperRef! linkTimeNonInherited TheHyperRefSpec := NULL.! ! !FeHyperRef class methodsFor: 'protected: wrapping'! {BooleanVar} check: edition {FeEdition} "Check that it has the right fields in the right places. Ignore other contents." ^(edition coordinateSpace isEqual: SequenceSpace make) and: [(edition domain intersects: (((Sequence string: 'HyperRef:PathContext') asRegion with: (Sequence string: 'HyperRef:WorkContext')) with: (Sequence string: 'HyperRef:OriginalContext'))) and: [(FeWrapper checkSubWork: edition with: (Sequence string: 'HyperRef:WorkContext') with: false) and: [(FeWrapper checkSubWork: edition with: (Sequence string: 'HyperRef:OriginalContext') with: false) and: [(FeWrapper checkSubEdition: edition with: (Sequence string: 'HyperRef:PathContext') with: FePath spec with: false)]]]]! {void} setSpec: spec {FeWrapperSpec} TheHyperRefSpec := spec.! ! !FeHyperRef class methodsFor: 'pseudo constructors'! {FeWrapperSpec} spec ^TheHyperRefSpec! ! !FeHyperRef class methodsFor: 'smalltalk: system'! info.stProtocol "{FeWork CLIENT} originalContext {FePath CLIENT} pathContext {FeHyperRef CLIENT} withOriginalContext: work {FeWork | NULL} {FeHyperRef CLIENT} withPathContext: path {FePath | NULL} {FeHyperRef CLIENT} withWorkContext: work {FeWork | NULL} {FeWork CLIENT} workContext "! !FeHyperRef subclass: #FeMultiRef instanceVariableNames: '' classVariableNames: 'TheMultiRefSpec {FeWrapperSpec} ' poolDictionaries: '' category: 'Xanadu-nlinks'! FeMultiRef comment: 'An undifferentiated set of HyperRefs'! (FeMultiRef getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !FeMultiRef methodsFor: 'private:'! {FeEdition} refsEdition "The Edition holding the HyperRefs" ^(self edition get: (Sequence string: 'MultiRef:Refs')) cast: FeEdition! {FeMultiRef} withRefsEdition: edition {FeEdition} "With a different refs Edition" Ravi thingToDo. "check about preserving labels" ^FeMultiRef construct: (self edition with: (Sequence string: 'MultiRef:Refs') with: edition)! ! !FeMultiRef methodsFor: 'accessing'! {FeMultiRef CLIENT} intersect: other {FeMultiRef} "Remove those not in the other Refs from the set." ^self withRefsEdition: (self refsEdition sharedWith: other refsEdition)! {FeMultiRef CLIENT} minus: other {FeMultiRef} "Remove the other Refs from the set." ^self withRefsEdition: (self refsEdition notSharedWith: other refsEdition)! {Stepper CLIENT of: FeHyperRef} refs "All the HyperRefs in the collection" Ravi shouldImplement. ^NULL "fodder"! {FeMultiRef CLIENT} unionWith: other {FeMultiRef} "Add the other Refs into the set." | added {FeEdition} result {FeEdition} stepper {Stepper} more {PrimArray} | added := other refsEdition notSharedWith: self refsEdition. added isEmpty ifTrue: [^self]. result := self refsEdition. stepper := added stepper. [stepper hasValue] whileTrue: [more := stepper stepMany. result := result combine: (FeEdition fromArray: more with: ((self refsEdition coordinateSpace cast: IDSpace) newIDs: more count))]. ^self withRefsEdition: result! {FeMultiRef CLIENT} with: ref {FeHyperRef} "Add a Ref to the set" (self refsEdition positionsOf: ref edition) isEmpty ifTrue: [^self withRefsEdition: (self refsEdition with: (self refsEdition coordinateSpace cast: IDSpace) newID with: ref edition)] ifFalse: [^self]! {FeMultiRef CLIENT} without: ref {FeHyperRef} "Add a Ref to the set" | keys {XnRegion} | (keys := self refsEdition positionsOf: ref edition) isEmpty ifTrue: [^self] ifFalse: [^self withRefsEdition: (self refsEdition copy: keys complement)]! ! !FeMultiRef methodsFor: 'protected:'! {FeHyperRef} makeNew: edition {FeEdition} "Make a new HyperRef of the same type with different contents" ^FeMultiRef construct: edition! ! !FeMultiRef methodsFor: 'private: create'! create: edition {FeEdition} with: spec {FeWrapperSpec} super create: edition with: spec! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FeMultiRef class instanceVariableNames: ''! (FeMultiRef getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !FeMultiRef class methodsFor: 'private: wrapping'! {BooleanVar} check: edition {FeEdition} "Check that it has the right fields in the right places. Ignore other contents." | refs {FeEdition} | ^(FeHyperRef check: edition) and: [(FeWrapper checkSubEdition: edition with: (Sequence string: 'MultiRef:Refs') with: NULL with: true) and: [((refs := (edition get: (Sequence string: 'MultiRef:Refs')) cast: FeEdition) coordinateSpace isKindOf: IDSpace) and: [FeWrapper checkSubEditions: refs with: refs domain with: FeHyperRef spec with: true]]]! {FeMultiRef} construct: edition {FeEdition} "Create a new wrapper and endorse it" self spec endorse: edition. ^(self makeWrapper: edition) cast: FeMultiRef.! {FeWrapper} makeWrapper: edition {FeEdition} "Just create a new wrapper" ^self create: edition with: self spec! {void} setSpec: wrap {FeWrapperSpec} TheMultiRefSpec := wrap.! ! !FeMultiRef class methodsFor: 'smalltalk: init'! initTimeNonInherited FeWrapperSpec DIRECTWRAPPER: 'MultiRef' with: 'HyperRef' with: #FeMultiRef.! linkTimeNonInherited TheMultiRefSpec := NULL.! ! !FeMultiRef class methodsFor: 'creation'! {FeMultiRef CLIENT} make: refs {PtrArray | NULL of: FeHyperRef} with: workContext {FeWork default: NULL} with: originalContext {FeWork default: NULL} with: pathContext {FePath default: NULL} "Make a new MultiRef. At least one of the parameters must be non-NULL. The originalContext, if supplied, must be a frozen Work." | result {FeEdition} refEdition {FeEdition} | (refs == NULL and: [workContext == NULL and: [originalContext == NULL and: [pathContext == NULL]]]) ifTrue: [Heaper BLAST: #MustSupplySomeHyperRefInformation]. (originalContext ~~ NULL and: [(originalContext fetchBe cast: BeWork) fetchEditClub ~~ NULL]) ifTrue: [Heaper BLAST: #OriginalContextMustBeFrozen]. refs == NULL ifTrue: [refEdition := FeEdition empty: IDSpace unique] ifFalse: [ | array {PtrArray of: FeEdition} | array := PtrArray nulls: refs count. Int32Zero almostTo: refs count do: [ :i {Int32} | array at: i store: ((refs get: i) cast: FeHyperRef) edition]. refEdition := FeEdition fromArray: array with: (IDSpace unique newIDs: array count)]. result := FeEdition fromOne: (Sequence string: 'MultiRef:Refs') with: refEdition. workContext ~~ NULL ifTrue: [result := result with: (Sequence string: 'HyperRef:WorkContext') with: workContext]. originalContext ~~ NULL ifTrue: [result := result with: (Sequence string: 'HyperRef:OriginalContext') with: originalContext]. pathContext ~~ NULL ifTrue: [result := result with: (Sequence string: 'HyperRef:PathContext') with: pathContext edition]. ^self construct: result! {FeWrapperSpec} spec ^TheMultiRefSpec! ! !FeMultiRef class methodsFor: 'smalltalk: system'! info.stProtocol "{FeMultiRef CLIENT} intersect: other {FeMultiRef} {FeMultiRef CLIENT} minus: other {FeMultiRef} {Stepper CLIENT of: FeHyperRef} refs {FeMultiRef CLIENT} unionWith: other {FeMultiRef} {FeMultiRef CLIENT} with: ref {FeHyperRef} {FeMultiRef CLIENT} without: ref {FeHyperRef} "! ! !FeMultiRef class methodsFor: 'smalltalk: defaults'! {FeMultiRef CLIENT} make: refs {PtrArray | NULL of: FeHyperRef} "Make a new SingleRef. At least one of the parameters must be non-NULL. The originalContext, if supplied, must be a frozen Work." ^self make: refs with: NULL with: NULL with: NULL! {FeMultiRef CLIENT} make: refs {PtrArray | NULL of: FeHyperRef} with: workContext {FeWork default: NULL} "Make a new SingleRef. At least one of the parameters must be non-NULL. The originalContext, if supplied, must be a frozen Work." ^self make: refs with: workContext with: NULL with: NULL! {FeMultiRef CLIENT} make: refs {PtrArray | NULL of: FeHyperRef} with: workContext {FeWork default: NULL} with: originalContext {FeWork default: NULL} "Make a new SingleRef. At least one of the parameters must be non-NULL. The originalContext, if supplied, must be a frozen Work." ^self make: refs with: workContext with: originalContext with: NULL! !FeHyperRef subclass: #FeSingleRef instanceVariableNames: '' classVariableNames: 'TheSingleRefSpec {FeWrapperSpec} ' poolDictionaries: '' category: 'Xanadu-nlinks'! FeSingleRef comment: 'Represents a single attachment to some material in the context of a Work, and maybe a Path beneath it.'! (FeSingleRef getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !FeSingleRef methodsFor: 'accessing'! {FeEdition CLIENT} excerpt "The material to which this HyperRef is attached." ^(self edition get: (Sequence string: 'HyperRef:Excerpt')) cast: FeEdition! {FeSingleRef CLIENT} withExcerpt: excerpt {FeEdition} "Make this Ref point at different material." ^FeSingleRef construct: (self edition with: (Sequence string: 'HyperRef:Excerpt') with: excerpt)! ! !FeSingleRef methodsFor: 'protected:'! {FeHyperRef} makeNew: edition {FeEdition} "Make a new HyperRef of the same type with different contents" ^FeSingleRef construct: edition! ! !FeSingleRef methodsFor: 'private: create'! create: edition {FeEdition} with: spec {FeWrapperSpec} super create: edition with: spec! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FeSingleRef class instanceVariableNames: ''! (FeSingleRef getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !FeSingleRef class methodsFor: 'private: wrapping'! {BooleanVar} check: edition {FeEdition} "Check that it has the right fields in the right places. Ignore other contents." ^(FeHyperRef check: edition) and: [FeWrapper checkSubEdition: edition with: (Sequence string: 'HyperRef:AttachedMaterial') with: NULL with: false]! {FeSingleRef} construct: edition {FeEdition} "Create a new wrapper and endorse it" self spec endorse: edition. ^(self makeWrapper: edition) cast: FeSingleRef! {FeWrapper} makeWrapper: edition {FeEdition} "Just create a new wrapper" ^self create: edition with: self spec! {void} setSpec: wrap {FeWrapperSpec} TheSingleRefSpec := wrap.! ! !FeSingleRef class methodsFor: 'creation'! {FeSingleRef CLIENT} make: material {FeEdition | NULL} with: workContext {FeWork default: NULL} with: originalContext {FeWork default: NULL} with: pathContext {FePath default: NULL} "Make a new SingleRef. At least one of the parameters must be non-NULL. The originalContext, if supplied, must be a frozen Work." | result {FeEdition} | (material == NULL and: [workContext == NULL and: [originalContext == NULL and: [pathContext == NULL]]]) ifTrue: [Heaper BLAST: #MustSupplySomeHyperRefInformation]. (originalContext ~~ NULL and: [(originalContext fetchBe cast: BeWork) fetchEditClub ~~ NULL]) ifTrue: [Heaper BLAST: #OriginalContextMustBeFrozen]. result := FeEdition empty: SequenceSpace make. workContext ~~ NULL ifTrue: [result := result with: (Sequence string: 'HyperRef:WorkContext') with: workContext]. originalContext ~~ NULL ifTrue: [result := result with: (Sequence string: 'HyperRef:OriginalContext') with: originalContext]. material ~~ NULL ifTrue: [result := result with: (Sequence string: 'HyperRef:Excerpt') with: material]. pathContext ~~ NULL ifTrue: [result := result with: (Sequence string: 'HyperRef:PathContext') with: pathContext edition]. ^self construct: result! {FeWrapperSpec} spec ^TheSingleRefSpec! ! !FeSingleRef class methodsFor: 'smalltalk: init'! initTimeNonInherited FeWrapperSpec DIRECTWRAPPER: 'SingleRef' with: 'HyperRef' with: #FeSingleRef.! linkTimeNonInherited TheSingleRefSpec := NULL.! ! !FeSingleRef class methodsFor: 'smalltalk: system'! info.stProtocol "{FeEdition CLIENT} excerpt "! ! !FeSingleRef class methodsFor: 'smalltalk: defaults'! {FeSingleRef CLIENT} make: material {FeEdition | NULL} "Make a new SingleRef. At least one of the parameters must be non-NULL. The originalContext, if supplied, must be a frozen Work." ^self make: material with: NULL with: NULL with: NULL! {FeSingleRef CLIENT} make: material {FeEdition | NULL} with: workContext {FeWork default: NULL} "Make a new SingleRef. At least one of the parameters must be non-NULL. The originalContext, if supplied, must be a frozen Work." ^self make: material with: workContext with: NULL with: NULL! {FeSingleRef CLIENT} make: material {FeEdition | NULL} with: workContext {FeWork default: NULL} with: originalContext {FeWork default: NULL} "Make a new SingleRef. At least one of the parameters must be non-NULL. The originalContext, if supplied, must be a frozen Work." ^self make: material with: workContext with: originalContext with: NULL! !FeWrapper subclass: #FeLockSmith instanceVariableNames: '' classVariableNames: 'TheLockSmithSpec {FeWrapperSpec} ' poolDictionaries: '' category: 'Xanadu-nadmin'! FeLockSmith comment: 'Describes how to obtain the authority of a Club.'! (FeLockSmith getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; yourself)! !FeLockSmith methodsFor: 'server locks'! {Lock} newLock: clubID {ID unused | NULL} "Create a new lock which, if satisfied, will give access to this club. If Club is NULL, then the lock will never be satisfied." self subclassResponsibility! ! !FeLockSmith methodsFor: 'protected: create'! create: edition {FeEdition} with: spec {FeWrapperSpec} super create: edition with: spec! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FeLockSmith class instanceVariableNames: ''! (FeLockSmith getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; yourself)! !FeLockSmith class methodsFor: 'smalltalk: initialization'! initTimeNonInherited FeWrapperSpec ABSTRACTWRAPPER: 'LockSmith' with: 'Wrapper' with: #FeLockSmith! linkTimeNonInherited TheLockSmithSpec := NULL.! ! !FeLockSmith class methodsFor: 'private: wrapping'! {void} setSpec: spec {FeWrapperSpec} TheLockSmithSpec := spec.! ! !FeLockSmith class methodsFor: 'pseudo constructors'! {FeWrapperSpec} spec ^TheLockSmithSpec! !FeLockSmith subclass: #FeBooLockSmith instanceVariableNames: '' classVariableNames: 'TheBooLockSmithSpec {FeWrapperSpec} ' poolDictionaries: '' category: 'Xanadu-nadmin'! FeBooLockSmith comment: 'Makes BooLocks; see the comment there'! (FeBooLockSmith getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !FeBooLockSmith methodsFor: 'server locks'! {Lock} newLock: clubID {ID | NULL} "Make a WallLock if clubID is NULL" clubID == NULL ifTrue: [^FeWallLockSmith make newLock: NULL] ifFalse: [^BooLock make: clubID with: self]! ! !FeBooLockSmith methodsFor: 'private: create'! create: edition {FeEdition} with: spec {FeWrapperSpec} super create: edition with: spec! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FeBooLockSmith class instanceVariableNames: ''! (FeBooLockSmith getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !FeBooLockSmith class methodsFor: 'private: wrapping'! {BooleanVar} check: edition {FeEdition} Ravi hack. ^(edition domain isEqual: (IntegerRegion make: IntegerVarZero with: 3)) "and: [((edition zoneOf: PrimSpec uInt8) domain isEqual: (IntegerRegion make: IntegerVarZero with: 3))" and: [((edition retrieve theOne cast: FeArrayBundle) array cast: PrimIntegerArray) contentsEqual: (UInt8Array string: 'boo')]"]"! {FeBooLockSmith} construct: edition {FeEdition} self spec endorse: edition. ^ (self makeWrapper: edition) cast: FeBooLockSmith! {FeWrapper} makeWrapper: edition {FeEdition} ^self create: edition with: self spec! {void} setSpec: wrap {FeWrapperSpec} TheBooLockSmithSpec := wrap.! ! !FeBooLockSmith class methodsFor: 'smalltalk: init'! initTimeNonInherited FeWrapperSpec DIRECTWRAPPER: 'BooLockSmith' with: 'LockSmith' with: #FeBooLockSmith.! linkTimeNonInherited TheBooLockSmithSpec := NULL.! ! !FeBooLockSmith class methodsFor: 'pseudo constructors'! {FeBooLockSmith CLIENT} make ^self construct: (FeEdition fromArray: (UInt8Array string: 'boo'))! {FeWrapperSpec} spec ^TheBooLockSmithSpec! !FeLockSmith subclass: #FeChallengeLockSmith instanceVariableNames: '' classVariableNames: 'TheChallengeLockSmithSpec {FeWrapperSpec} ' poolDictionaries: '' category: 'Xanadu-nadmin'! FeChallengeLockSmith comment: 'Makes ChallengeLocks; see the comment there'! (FeChallengeLockSmith getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !FeChallengeLockSmith methodsFor: 'accessing'! {UInt8Array CLIENT} encrypterName "The type of encrypter used to create encrypted challenges." ^((((self edition get: (Sequence string: 'ChallengeLockSmith:EncrypterName')) cast: FeEdition) retrieve theOne) cast: FeArrayBundle) array cast: UInt8Array! {UInt8Array CLIENT} publicKey "The public key used to construct challenges." ^((((self edition get: (Sequence string: 'ChallengeLockSmith:PublicKey')) cast: FeEdition) retrieve theOne) cast: FeArrayBundle) array cast: UInt8Array! ! !FeChallengeLockSmith methodsFor: 'server locks'! {Lock} newLock: clubID {ID | NULL} self thingToDo. "Make this random" ^ChallengeLock make: clubID with: self with: (UInt8Array string: 'random')! ! !FeChallengeLockSmith methodsFor: 'private: create'! create: edition {FeEdition} with: spec {FeWrapperSpec} super create: edition with: spec! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FeChallengeLockSmith class instanceVariableNames: ''! (FeChallengeLockSmith getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !FeChallengeLockSmith class methodsFor: 'pseudo constructors'! {FeChallengeLockSmith CLIENT} make: publicKey {PrimIntArray} with: encrypterName {Sequence} | result {FeEdition} | result := FeEdition fromOne: (Sequence string: 'ChallengeLockSmith:PublicKey') with: (FeEdition fromArray: (publicKey cast: UInt8Array)). result := result with: (Sequence string: 'ChallengeLockSmith:EncrypterName') with: (FeEdition fromArray: encrypterName integers). ^self construct: result! {FeWrapperSpec} spec ^TheChallengeLockSmithSpec! ! !FeChallengeLockSmith class methodsFor: 'private: wrapping'! {BooleanVar} check: edition {FeEdition} ^(edition domain isEqual: ((Sequence string: 'ChallengeLockSmith:EncrypterName') asRegion with: (Sequence string: 'ChallengeLockSmith:PublicKey'))) and: [(FeWrapper checkSubSequence: edition with: (Sequence string: 'ChallengeLockSmith:EncrypterName') with: true) and: [FeWrapper checkSubSequence: edition with: (Sequence string: 'ChallengeLockSmith:PublicKey') with: true]]! {FeChallengeLockSmith} construct: edition {FeEdition} self spec endorse: edition. ^ (self makeWrapper: edition) cast: FeChallengeLockSmith! {FeWrapper} makeWrapper: edition {FeEdition} ^self create: edition with: self spec! {void} setSpec: wrap {FeWrapperSpec} TheChallengeLockSmithSpec := wrap.! ! !FeChallengeLockSmith class methodsFor: 'smalltalk: init'! initTimeNonInherited FeWrapperSpec DIRECTWRAPPER: 'ChallengeLockSmith' with: 'LockSmith' with: #FeChallengeLockSmith.! linkTimeNonInherited TheChallengeLockSmithSpec := NULL.! ! !FeChallengeLockSmith class methodsFor: 'smalltalk: system'! info.stProtocol "{PrimIntegerArray CLIENT} encrypterName {UInt8Array CLIENT} publicKey "! !FeLockSmith subclass: #FeMatchLockSmith instanceVariableNames: '' classVariableNames: 'TheMatchLockSmithSpec {FeWrapperSpec} ' poolDictionaries: '' category: 'Xanadu-nadmin'! FeMatchLockSmith comment: 'Makes MatchLocks; see the comment there'! (FeMatchLockSmith getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !FeMatchLockSmith methodsFor: 'accessing'! {UInt8Array CLIENT} scrambledPassword "The password in scrambled form. If the scrambler is any good, this should be meaningless." ^((((self edition get: (Sequence string: 'MatchLockSmith:ScrambledPassword')) cast: FeEdition) retrieve theOne) cast: FeArrayBundle) array cast: UInt8Array! {UInt8Array CLIENT} scramblerName "The name of scrambler being used to scramble the password." ^((((self edition get: (Sequence string: 'MatchLockSmith:ScramblerName')) cast: FeEdition) retrieve theOne) cast: FeArrayBundle) array cast: UInt8Array! ! !FeMatchLockSmith methodsFor: 'server locks'! {Lock} newLock: clubID {ID | NULL} ^MatchLock make: clubID with: self! ! !FeMatchLockSmith methodsFor: 'private: create'! create: edition {FeEdition} with: spec {FeWrapperSpec} super create: edition with: spec! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FeMatchLockSmith class instanceVariableNames: ''! (FeMatchLockSmith getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !FeMatchLockSmith class methodsFor: 'private: wrapping'! {BooleanVar} check: edition {FeEdition} ^(edition domain isEqual: ((Sequence string: 'MatchLockSmith:ScramblerName') asRegion with: (Sequence string: 'MatchLockSmith:ScrambledPassword'))) and: [(FeWrapper checkSubSequence: edition with: (Sequence string: 'MatchLockSmith:ScramblerName') with: true) and: [FeWrapper checkSubSequence: edition with: (Sequence string: 'MatchLockSmith:ScrambledPassword') with: true]]! {FeMatchLockSmith} construct: edition {FeEdition} self spec endorse: edition. ^ (self makeWrapper: edition) cast: FeMatchLockSmith! {FeWrapper} makeWrapper: edition {FeEdition} ^self create: edition with: self spec! {void} setSpec: wrap {FeWrapperSpec} TheMatchLockSmithSpec := wrap.! ! !FeMatchLockSmith class methodsFor: 'smalltalk: init'! initTimeNonInherited FeWrapperSpec DIRECTWRAPPER: 'MatchLockSmith' with: 'LockSmith' with: #FeMatchLockSmith.! linkTimeNonInherited TheMatchLockSmithSpec := NULL.! ! !FeMatchLockSmith class methodsFor: 'pseudo constructors'! {FeMatchLockSmith CLIENT} make: scrambledPassword {PrimIntArray} with: scramblerName {Sequence} | result {FeEdition} | result := FeEdition fromOne: (Sequence string: 'MatchLockSmith:ScrambledPassword') with: (FeEdition fromArray: (scrambledPassword cast: UInt8Array)). result := result with: (Sequence string: 'MatchLockSmith:ScramblerName') with: (FeEdition fromArray: scramblerName integers). ^self construct: result! {FeWrapperSpec} spec ^TheMatchLockSmithSpec! ! !FeMatchLockSmith class methodsFor: 'smalltalk: system'! info.stProtocol "{UInt8Array CLIENT} scrambledPassword {PrimIntegerArray CLIENT} scramblerName "! !FeLockSmith subclass: #FeMultiLockSmith instanceVariableNames: '' classVariableNames: 'TheMultiLockSmithSpec {FeWrapperSpec} ' poolDictionaries: '' category: 'Xanadu-nadmin'! FeMultiLockSmith comment: 'Makes MultiLocks; see the comment there'! (FeMultiLockSmith getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !FeMultiLockSmith methodsFor: 'server locks'! {Lock} newLock: clubID {ID | NULL} | result {MuTable of: Lock} | result := MuTable make: SequenceSpace make. self edition stepper forPositions: [ :name {Sequence} :smith {FeEdition} | result at: name introduce: (((FeLockSmith spec wrap: smith) cast: FeLockSmith) newLock: clubID)]. ^MultiLock make: clubID with: self with: result asImmuTable! ! !FeMultiLockSmith methodsFor: 'accessing'! {FeLockSmith CLIENT} lockSmith: name {Sequence} "The named LockSmith" ^(FeLockSmith spec wrap: ((self edition get: name) cast: FeEdition)) cast: FeLockSmith! {SequenceRegion CLIENT of: Sequence} lockSmithNames "The names of all the Locksmiths this uses." ^self edition domain cast: SequenceRegion! {FeMultiLockSmith CLIENT} with: name {Sequence} with: smith {FeLockSmith} "Add or change a LockSmith" ^(FeMultiLockSmith construct: (self edition with: name with: smith edition)) cast: FeMultiLockSmith! {FeMultiLockSmith CLIENT} without: name {Sequence} "Add or change a LockSmith" ^(FeMultiLockSmith construct: (self edition without: name)) cast: FeMultiLockSmith! ! !FeMultiLockSmith methodsFor: 'private: create'! create: edition {FeEdition} with: spec {FeWrapperSpec} super create: edition with: spec! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FeMultiLockSmith class instanceVariableNames: ''! (FeMultiLockSmith getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !FeMultiLockSmith class methodsFor: 'private: wrapping'! {BooleanVar} check: edition {FeEdition} ^(SequenceSpace make isEqual: edition coordinateSpace) and: [FeWrapper checkSubEditions: edition with: edition domain with: FeLockSmith spec with: true]! {FeMultiLockSmith} construct: edition {FeEdition} self spec endorse: edition. ^ (self makeWrapper: edition) cast: FeMultiLockSmith! {FeWrapper} makeWrapper: edition {FeEdition} ^self create: edition with: self spec! {void} setSpec: wrap {FeWrapperSpec} TheMultiLockSmithSpec := wrap.! ! !FeMultiLockSmith class methodsFor: 'smalltalk: init'! initTimeNonInherited FeWrapperSpec DIRECTWRAPPER: 'MultiLockSmith' with: 'LockSmith' with: #FeMultiLockSmith.! linkTimeNonInherited TheMultiLockSmithSpec := NULL.! ! !FeMultiLockSmith class methodsFor: 'pseudo constructors'! {FeMultiLockSmith CLIENT} make ^self construct: (FeEdition empty: SequenceSpace make)! {FeWrapperSpec} spec ^TheMultiLockSmithSpec! ! !FeMultiLockSmith class methodsFor: 'smalltalk: system'! info.stProtocol "{FeLockSmith CLIENT} lockSmith: name {Sequence} {SequenceRegion CLIENT of: Sequence} lockSmithNames {FeMultiLockSmith CLIENT} with: name {Sequence} with: smith {FeLockSmith} {FeMultiLockSmith CLIENT} without: name {Sequence} "! !FeLockSmith subclass: #FeWallLockSmith instanceVariableNames: '' classVariableNames: 'TheWallLockSmithSpec {FeWrapperSpec} ' poolDictionaries: '' category: 'Xanadu-nadmin'! FeWallLockSmith comment: 'Makes WallLocks; see the comment there'! (FeWallLockSmith getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !FeWallLockSmith methodsFor: 'server locks'! {Lock} newLock: clubID {ID | NULL} ^WallLock make: clubID with: self! ! !FeWallLockSmith methodsFor: 'private: create'! create: edition {FeEdition} with: spec {FeWrapperSpec} super create: edition with: spec! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FeWallLockSmith class instanceVariableNames: ''! (FeWallLockSmith getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !FeWallLockSmith class methodsFor: 'private: wrapping'! {BooleanVar} check: edition {FeEdition} Ravi hack. ^(edition domain isEqual: (IntegerRegion make: IntegerVarZero with: 4)) "and: [((edition zoneOf: PrimSpec uInt8) domain isEqual: (IntegerRegion make: IntegerVarZero with: 4))" and: [((edition retrieve theOne cast: FeArrayBundle) array cast: PrimIntegerArray) contentsEqual: (UInt8Array string: 'wall')]"]"! {FeWallLockSmith} construct: edition {FeEdition} self spec endorse: edition. ^ (self makeWrapper: edition) cast: FeWallLockSmith! {FeWrapper} makeWrapper: edition {FeEdition} ^self create: edition with: self spec! {void} setSpec: wrap {FeWrapperSpec} TheWallLockSmithSpec := wrap.! ! !FeWallLockSmith class methodsFor: 'smalltalk: init'! initTimeNonInherited FeWrapperSpec DIRECTWRAPPER: 'WallLockSmith' with: 'LockSmith' with: #FeWallLockSmith.! linkTimeNonInherited TheWallLockSmithSpec := NULL.! ! !FeWallLockSmith class methodsFor: 'pseudo constructors'! {FeWallLockSmith CLIENT} make ^self construct: (FeEdition fromArray: (UInt8Array string: 'wall'))! {FeWrapperSpec} spec ^TheWallLockSmithSpec! !FeWrapper subclass: #FePath instanceVariableNames: '' classVariableNames: 'ThePathSpec {FeWrapperSpec} ' poolDictionaries: '' category: 'Xanadu-nlinks'! FePath comment: 'A sequence of Labels, used for context information in a LinkEnd.'! (FePath getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !FePath methodsFor: 'smalltalk: passe'! {FeLabel} first "The first label in the sequence" self passe. ^(self edition get: IntegerZero) cast: FeLabel! {FeEdition} replace: container {FeEdition} with: contained {FeRangeElement} with: index {IntegerVar} with: count {IntegerVar} "Replace what is in the container at my path after index with contained." | labels {XnRegion} | index = count ifTrue: [^contained cast: FeEdition]. labels := container positionsLabelled: ((self edition get: index integer) cast: FeLabel). ^container with: labels theOne with: (self replace: ((container get: labels theOne) cast: FeEdition) with: contained with: index + 1 with: count)! {FeEdition} replaceIn: container {FeEdition} with: value {FeRangeElement} "Replace whatever is at this path in the container with the newValue. Fail if at any point there is not precisely one choice." self passe. ^self replace: container with: value with: IntegerVarZero with: self edition count! {FePath} rest "The remaining path after the first label in the sequence" self passe. ^(FePath construct: (self edition transformedBy: ((IntegerMapping make: -1) restrict: (IntegerRegion after: 1)))) cast: FePath! {FePath} withFirst: label {FeLabel} "Append it to the beginning of the path" self passe. ^(FePath construct: ((self edition transformedBy: ((IntegerMapping make: 1) restrict: (IntegerRegion after: 1))) with: IntegerZero with: label)) cast: FePath! {FePath} withLast: label {FeLabel} "Append it to the end of the path" self passe. ^(FePath construct: (self edition with: self edition count with: label)) cast: FePath! ! !FePath methodsFor: 'operations'! {FeRangeElement CLIENT} follow: edition {FeEdition} "Follow a path down into an Edition and return what is at the end of the path. Fail if at any point there is not precisely one choice." | result {FeRangeElement} label {FeLabel} | result := edition. IntegerVarZero almostTo: self edition count do: [ :index {IntegerVar} | label := (self edition get: index integer) cast: FeLabel. result := (result cast: FeEdition) get: ((result cast: FeEdition) positionsLabelled: label) theOne]. ^result! ! !FePath methodsFor: 'private: create'! create: edition {FeEdition} with: spec {FeWrapperSpec} super create: edition with: spec! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FePath class instanceVariableNames: ''! (FePath getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !FePath class methodsFor: 'pseudo constructors'! {FePath CLIENT} make: labels {PtrArray of: FeLabel} ^(self spec wrap: (FeEdition fromArray: labels)) cast: FePath! {FeWrapperSpec} spec ^ThePathSpec! ! !FePath class methodsFor: 'private: wrapping'! {BooleanVar} check: edition {FeEdition} Ravi thingToDo. "check that there are only labels here" ^(edition domain isKindOf: IntegerRegion) and: [(edition domain cast: IntegerRegion) isCompacted "and: [((edition zoneOf: FeLabel spec) domain isEqual: edition domain)]"]! {FePath} construct: edition {FeEdition} self spec endorse: edition. ^(self makeWrapper: edition) cast: FePath! {FeWrapper} makeWrapper: edition {FeEdition} ^self create: edition with: self spec! {void} setSpec: wrap {FeWrapperSpec} ThePathSpec := wrap.! ! !FePath class methodsFor: 'smalltalk: init'! initTimeNonInherited FeWrapperSpec DIRECTWRAPPER: 'Path' with: 'Wrapper' with: #FePath.! linkTimeNonInherited ThePathSpec := NULL.! ! !FePath class methodsFor: 'smalltalk: system'! info.stProtocol "{FeRangeElement CLIENT} follow: edition {FeEdition} "! !FeWrapper subclass: #FeSet instanceVariableNames: '' classVariableNames: 'TheSetSpec {FeWrapperSpec} ' poolDictionaries: '' category: 'Xanadu-wrapper'! FeSet comment: 'An undifferentiated set of RangeElements.'! (FeSet getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !FeSet methodsFor: 'private:'! {IDSpace} iDSpace ^self edition coordinateSpace cast: IDSpace! ! !FeSet methodsFor: 'accessing'! {IntegerVar CLIENT} count "The number of elements in the set" ^self edition count! {BooleanVar CLIENT} includes: value {FeRangeElement} "Whether the set includes the given RangeElement" ^(self edition keysOf: value) isEmpty not! {FeSet CLIENT} intersect: other {FeSet} "Return those elements which are in both sets" ^FeSet construct: (self edition sharedWith: other edition)! {FeSet CLIENT} minus: other {FeSet} "Remove some RangeElements from the set" ^FeSet construct: (self edition notSharedWith: other edition)! {Stepper of: FeRangeElement} stepper "A stepper over the elements in the set" ^self edition stepper! {FeRangeElement CLIENT} theOne "If there is exactly one element, then return it" ^self edition theOne! {FeSet CLIENT} unionWith: other {FeSet} "Return those elements which are in either set" | added {FeEdition} result {FeEdition} stepper {Stepper} more {PrimArray} | "Need to assign new IDs to avoid collisions" added := other edition notSharedWith: self edition. added isEmpty ifTrue: [^self]. result := self edition. stepper := added stepper. [stepper hasValue] whileTrue: [more := stepper stepMany. result := result combine: (FeEdition fromArray: more with: ((self edition coordinateSpace cast: IDSpace) newIDs: more count))]. ^FeSet construct: result! {FeSet CLIENT} with: value {FeRangeElement} "Add a RangeElement to the set" (self includes: value) ifTrue: [^self] ifFalse: [^FeSet construct: (self edition with: self iDSpace newID with: value)]! {FeSet CLIENT} without: value {FeRangeElement} "Remove a RangeElement from the set" ^FeSet construct: (self edition notSharedWith: (FeEdition fromOne: IntegerVar0 integer with: value))! ! !FeSet methodsFor: 'smalltalk: passe'! {IntegerVar} count: spec {PrimSpec default: NULL} "How many elements in the set; if a spec is given, then how many elements of the given spec are in the set" self passe. spec == NULL ifTrue: [^self edition count] ifFalse: [^(self edition zoneOf: spec) count]! {IntegerVar} countEditions: spec {FeWrapperSpec default: NULL} "How many elements in the set are Editions; if a spec is given, then how many of them satisfy the given spec" | editions {FeEdition} result {IntegerVar} | self passe. result := IntegerVarZero. editions := self edition zoneOf: (PrimSpec pointer: FeEdition). spec == NULL ifTrue: [^editions count]. editions stepper forEach: [ :sub {FeEdition} | (spec certify: sub) ifTrue: [result := result + 1]]. ^result! {IDRegion} iDs self passe "globalIDs"! ! !FeSet methodsFor: 'protected: create'! create: edition {FeEdition} with: spec {FeWrapperSpec} super create: edition with: spec! ! !FeSet methodsFor: 'printing'! {void} printOn: oo {ostream reference} | count {IntegerVar} | oo << self getCategory name << '('. count := IntegerVarZero. self stepper forEach: [ :object {FeRangeElement} | count > IntegerVarZero ifTrue: [oo << ', '. count > 5 ifTrue: [oo << '...)'. ^VOID]]. oo << object]. oo << ')'! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FeSet class instanceVariableNames: ''! (FeSet getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !FeSet class methodsFor: 'pseudo constructors'! {FeSet CLIENT} make ^self construct: (FeEdition empty: IDSpace unique)! {FeSet CLIENT} make: works {PtrArray of: FeRangeElement} ^(self spec wrap: (FeEdition fromArray: works with: (IDSpace unique newIDs: works count))) cast: FeSet! {FeWrapperSpec} spec ^TheSetSpec! ! !FeSet class methodsFor: 'private: wrapping'! {BooleanVar} check: edition {FeEdition} ^(edition coordinateSpace isKindOf: IDSpace) and: [edition isFinite]! {FeSet} construct: edition {FeEdition} self spec endorse: edition. ^(self makeWrapper: edition) cast: FeSet! {FeWrapper} makeWrapper: edition {FeEdition} ^self create: edition with: self spec! {void} setSpec: wrap {FeWrapperSpec} TheSetSpec := wrap.! ! !FeSet class methodsFor: 'smalltalk: init'! initTimeNonInherited FeWrapperSpec DIRECTWRAPPER: 'Set' with: 'Wrapper' with: #FeSet.! linkTimeNonInherited TheSetSpec := NULL.! ! !FeSet class methodsFor: 'smalltalk: system'! info.stProtocol "{IntegerVar CLIENT} count {BooleanVar CLIENT} includes: value {FeRangeElement} {FeSet CLIENT} intersect: other {FeSet} {FeSet CLIENT} minus: other {FeSet} {FeRangeElement CLIENT} theOne {FeSet CLIENT} unionWith: other {FeSet} {FeSet CLIENT} with: value {FeRangeElement} {FeSet CLIENT} without: value {FeRangeElement} "! !FeWrapper subclass: #FeText instanceVariableNames: '' classVariableNames: 'TheTextSpec {FeWrapperSpec} ' poolDictionaries: '' category: 'Xanadu-wrapper'! FeText comment: 'Handles a integer-indexed, contiguous, zero-based Edition of RangeElements'! (FeText getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !FeText methodsFor: 'text manipulation'! {FeEdition CLIENT} contents "The Edition of the actual contents, without any style information. You should use this instead of edition() when you want to get the Edition for comparisons, queries, etc. Future styled text implementations will not store the contents as directly as we do now." ^self edition! {IntegerVar CLIENT} count "The number of elements in the string" ^self edition count! {FeText CLIENT} extract: region {IntegerRegion} "All the text lying within the region, with the gaps compressed out." ^FeText construct: (self edition transformedBy: ((region intersect: self edition domain) cast: IntegerRegion) compactor)! {FeText CLIENT} insert: position {IntegerVar} with: text {FeText} "Insert new information into the Edition at the given point, pushing everything after it forward." self validate: position. ^FeText construct: ((text edition transformedBy: (IntegerMapping make: position)) combine: (self edition transformedBy: ((IntegerMapping make restrict: (IntegerRegion before: position)) combine: ((IntegerMapping make: text count) restrict: (IntegerRegion after: position)))))! {FeText CLIENT} move: pos {IntegerVar} with: region {IntegerRegion} "Insert a virtual copy of the region of text before the given position, and remove it from its current location. If the position is one past the last character, then it will be inserted after the end. If the region is discontiguous, then the contiguous pieces are concatenated together, in sequence, and inserted." | moved {IntegerRegion} left {IntegerRegion} | self validate: pos. moved := (self edition domain intersect: region) cast: IntegerRegion. left := (self edition domain minus: region) cast: IntegerRegion. ^FeText construct: (self edition transformedBy: ((((left intersect: (IntegerRegion before: pos)) cast: IntegerRegion) compactor combine: (moved compactor transformedBy: (IntegerMapping make: pos))) combine: (((left intersect: (IntegerRegion after: pos)) cast: IntegerRegion) compactor transformedBy: (IntegerMapping make: (moved unionWith: (IntegerRegion make: IntegerVar0 with: pos)) count))))! {FeText CLIENT} replace: dest {IntegerRegion} with: other {FeText} "Replaces a region of text with a virtual copy of text from another document. If the destination region lies to the left of the domain, inserts before the beginning; if it intersects the domain, insert at the first common position; if it lies after the end, insert after the end. Fails with BLAST(AmbiguousReplacement) if the region is empty. May be used to copy information within a single document. This operation may not be particularly useful with non-simple destination regions." | to {IntegerVar} | ((IntegerRegion before: IntegerVar0) intersects: dest) ifTrue: [to := IntegerVar0] ifFalse: [(dest intersects: self edition domain) ifTrue: [to := ((dest intersect: self edition domain) cast: IntegerRegion) start] ifFalse: [((IntegerRegion after: self count) intersects: dest) ifTrue: [to := self count] ifFalse: [Heaper BLAST: #AmbiguousReplacement]]]. self thingToDo. "Do this all in one step" ^(self extract: (dest complement cast: IntegerRegion)) insert: to with: other! ! !FeText methodsFor: 'private:'! {void} validate: pos {IntegerVar} "Check that information can be inserted at the position. Blast if not." (IntegerVar0 <= pos and: [pos <= self count]) ifFalse: [Heaper BLAST: #InvalidTextPosition]! ! !FeText methodsFor: 'protected: create'! create: edition {FeEdition} with: spec {FeWrapperSpec} super create: edition with: spec! ! !FeText methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '('. "(self edition copy: (IntegerRegion before: 100)) retrieve forEach: [ :bundle {FeBundle} | bundle cast: FeArrayBundle into: [ :array | array array cast: UInt8Array into: [ :chars | oo << chars] others: [UInt32Zero almostTo: array array count do: [ :i {UInt32} | oo << (array get: i)]]] cast: FeElementBundle into: [ :element | ] cast: FePlaceHolderBundle into: [ :places | ]]. (self edition isFinite not or: [self edition count > 100]) ifTrue: [oo << '...']." oo << self edition. "for now" oo << ')'! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FeText class instanceVariableNames: ''! (FeText getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !FeText class methodsFor: 'private: wrapping'! {BooleanVar} check: edition {FeEdition} ^(IntegerSpace make isEqual: edition coordinateSpace) and: [(edition domain cast: IntegerRegion) isCompacted]! {FeText} construct: edition {FeEdition} "Called from internal code to create and endorse new Editions. Does not check the contents; assumes that it will only be called by trusted code." self spec endorse: edition. ^(self makeWrapper: edition) cast: FeText! {FeWrapper} makeWrapper: edition {FeEdition} ^self create: edition with: self spec! {void} setSpec: wrap {FeWrapperSpec} TheTextSpec := wrap.! ! !FeText class methodsFor: 'smalltalk: init'! initTimeNonInherited FeWrapperSpec DIRECTWRAPPER: 'Text' with: 'Wrapper' with: #FeText! linkTimeNonInherited TheTextSpec := NULL.! ! !FeText class methodsFor: 'pseudo constructors'! {FeText CLIENT} make: data {PrimArray default: NULL} data == NULL ifTrue: [^self construct: (FeEdition empty: IntegerSpace make)] ifFalse: [^self construct: (FeEdition fromArray: data)]! {FeWrapperSpec} spec ^TheTextSpec! ! !FeText class methodsFor: 'smalltalk: system'! info.stProtocol "{FeEdition CLIENT} contents {IntegerVar CLIENT} count {FeText CLIENT} extract: region {IntegerRegion} {FeText CLIENT} insert: position {IntegerVar} with: text {FeText} {FeText CLIENT} move: pos {IntegerVar} with: region {IntegerRegion} {FeText CLIENT} replace: dest {IntegerRegion} with: other {FeText} "! !FeWrapper subclass: #FeWorkSet instanceVariableNames: '' classVariableNames: 'TheWorkSetSpec {FeWrapperSpec} ' poolDictionaries: '' category: 'Xanadu-wrapper'! FeWorkSet comment: 'An undifferentiated set of Works. Last minute bulletin: This will probably be changed to be a set of any kind of RangeElements, with protocol for testing types.'! (FeWorkSet getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #OBSOLETE; add: #SMALLTALK.ONLY; yourself)! !FeWorkSet methodsFor: 'private:'! {IDSpace} iDSpace ^self edition coordinateSpace cast: IDSpace! ! !FeWorkSet methodsFor: 'accessing'! {IDRegio} iDs "The current global IDs of all of the Works contained" ^FeServer iDsOfRange: self edition! {BooleanVar} includes: work {FeWork} "Whether the set includes the given Work" ^(self edition keysOf: work) isEmpty not! {FeWorkSet} intersect: other {FeWorkSet} "Return those which are in both sets" ^FeWorkSet construct: (self edition sharedWith: other edition)! {FeWorkSet} minus: other {FeWorkSet} "Remove some Works from the set" ^FeWorkSet construct: (self edition notSharedWith: other edition)! {FeWorkSet} unionWith: other {FeWorkSet} "Return those which are in either set" | added {FeEdition} | "Need to assign new IDs to avoid collisions" added := other notSharedWIth: self. added isEmpty ifTrue: [^self]. ^FeWorkSet construct: (self edition combine: (FeEdition fromArray: added retrieve with: (self iDSpace newIDs: added count)))! {FeWorkSet} with: work {FeWork} "Add a Work to the set" (self includes: work) ifTrue: [^self] ifFalse: [^FeWorkSet construct: (self edition with: self iDSpace newID with: work)]! {FeWorkSet} without: work {FeWork} "Remove a Work from the set" ^FeWorkSet construct: (self edition notSharedWith: (FeEdition fromOne: IntegerVar0 integer with: work))! {PtrArray of: FeWork} works "The Works in the set" ^self edition retrieve! ! !FeWorkSet methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << $(. self edition stepper forEach: [ :work {FeWork} | oo << $ << work]. oo << $)! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FeWorkSet class instanceVariableNames: ''! (FeWorkSet getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #OBSOLETE; add: #SMALLTALK.ONLY; yourself)! !FeWorkSet class methodsFor: 'pseudo constructors'! {FeWorkSet} make ^self construct: (FeEdition empty: IDSpace unique)! {FeWorkSet} make: works {PtrArray of: FeWork} ^self spec wrap: (FeEdition fromArray: works with: (IDSpace unique newIDs: works count))! {FeWrapperSpec} spec ^TheWorkSetSpec! ! !FeWorkSet class methodsFor: 'private: wrapping'! {BooleanVar} check: edition {FeEdition} Ravi hack. "zones stuff" ^(edition coordinateSpace isKindOf: IDSpace) and: [edition isFinite "and: [edition count = (edition zoneOf: FeWork spec) count]"]! {FeWorkSet} construct: edition {FeEdition} self spec endorse: edition. ^(self makeWrapper: edition) cast: FeWorkSet! {FeWrapper} makeWrapper: edition {FeEdition} ^self create: edition with: self spec! {void} setSpec: wrap {FeWrapperSpec} TheWorkSetSpec := wrap.! ! !FeWorkSet class methodsFor: 'smalltalk: init'! initTimeNonInherited FeWrapperSpec DIRECTWRAPPER: 'WorkSet' with: 'Wrapper' with: #FeWorkSet.! linkTimeNonInherited TheWorkSetSpec := NULL.! !Heaper subclass: #FeWrapperDef instanceVariableNames: ' myName {Sequence} mySuperDefName {Sequence | NULL} mySpecHolder {FeWrapperSpecHolder var}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-wrapper'! FeWrapperDef comment: '?I: names ?P: strings ?P: PackOBits'! (FeWrapperDef getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #EQ; yourself)! !FeWrapperDef methodsFor: 'accessing'! {Sequence | NULL} fetchSuperDefName ^mySuperDefName! {FeWrapperSpec} makeSpec "Make a WrapperSpec for this definition and return it" self subclassResponsibility! {Sequence} name ^myName! {void} setSpec: spec {FeWrapperSpec} "Tell whoever cares about the spec for this type" mySpecHolder ~~ NULL ifTrue: [mySpecHolder invokeFunction: spec]! ! !FeWrapperDef methodsFor: 'create'! create: name {Sequence} with: superName {Sequence | NULL} with: holder {FeWrapperSpecHolder var | NULL} super create. myName := name. mySuperDefName := superName. mySpecHolder := holder.! ! !FeWrapperDef methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FeWrapperDef class instanceVariableNames: ''! (FeWrapperDef getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #EQ; yourself)! !FeWrapperDef class methodsFor: 'pseudo constructors'! {FeWrapperDef} abstract: wrapperName {Sequence} with: superName {Sequence | NULL} with: holder {FeWrapperSpecHolder var | NULL} ^FeAbstractWrapperDef create: wrapperName with: superName with: holder! {FeWrapperDef} makeDirect: wrapperName {Sequence} with: superName {Sequence | NULL} with: holder {FeWrapperSpecHolder var | NULL} with: maker {FeDirectWrapperMaker var} with: checker {FeDirectWrapperChecker var} ^FeDirectWrapperDef create: wrapperName with: superName with: holder with: maker with: checker! {FeWrapperDef} makeIndirect: wrapperName {Sequence} with: superName {Sequence | NULL} with: holder {FeWrapperSpecHolder var | NULL} with: innerName {Sequence | NULL} with: maker {FeIndirectWrapperMaker var} with: checker {FeIndirectWrapperChecker var} ^FeIndirectWrapperDef create: wrapperName with: superName with: holder with: innerName with: maker with: checker! !FeWrapperDef subclass: #FeAbstractWrapperDef instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-wrapper'! (FeAbstractWrapperDef getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; yourself)! !FeAbstractWrapperDef methodsFor: 'create'! create: name {Sequence} with: superName {Sequence | NULL} with: holder {FeWrapperSpecHolder var | NULL} super create: name with: superName with: holder.! ! !FeAbstractWrapperDef methodsFor: 'accessing'! {FeWrapperSpec} makeSpec ^FeAbstractWrapperSpec make: self! ! !FeAbstractWrapperDef methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! !FeWrapperDef subclass: #FeDirectWrapperDef instanceVariableNames: ' myMaker {FeDirectWrapperMaker var} myChecker {FeDirectWrapperChecker var}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-wrapper'! (FeDirectWrapperDef getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; yourself)! !FeDirectWrapperDef methodsFor: 'accessing'! {BooleanVar} check: edition {FeEdition} ^myChecker invokeFunction: edition! {FeWrapperSpec} makeSpec ^FeDirectWrapperSpec make: self! {FeWrapper} makeWrapper: edition {FeEdition} ^myMaker invokeFunction: edition! ! !FeDirectWrapperDef methodsFor: 'create'! create: name {Sequence} with: superName {Sequence | NULL} with: holder {FeWrapperSpecHolder var | NULL} with: maker {FeDirectWrapperMaker var} with: checker {FeDirectWrapperChecker var} super create: name with: superName with: holder. myMaker := maker. myChecker := checker.! ! !FeDirectWrapperDef methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! !FeWrapperDef subclass: #FeIndirectWrapperDef instanceVariableNames: ' myInner {Sequence} myMaker {FeIndirectWrapperMaker var} myChecker {FeIndirectWrapperChecker var}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-wrapper'! (FeIndirectWrapperDef getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; yourself)! !FeIndirectWrapperDef methodsFor: 'accessing'! {BooleanVar} check: inner {FeEdition} ^myChecker invokeFunction: inner! {Sequence} innerDefName ^myInner! {FeWrapperSpec} makeSpec ^FeIndirectWrapperSpec make: self! {FeWrapper} makeWrapper: edition {FeEdition} with: inner {FeWrapper} ^myMaker invokeFunction: edition with: inner! ! !FeIndirectWrapperDef methodsFor: 'create'! create: name {Sequence} with: superName {Sequence | NULL} with: holder {FeWrapperSpecHolder var | NULL} with: maker {FeIndirectWrapperMaker var} with: checker {FeIndirectWrapperChecker var} super create: name with: superName with: holder. myMaker := maker. myChecker := checker.! create: name {Sequence} with: superName {Sequence | NULL} with: holder {FeWrapperSpecHolder var | NULL} with: inner {Sequence | NULL} with: maker {FeIndirectWrapperMaker var} with: checker {FeIndirectWrapperChecker var} super create: name with: superName with: holder. myInner := inner. myMaker := maker. myChecker := checker.! ! !FeIndirectWrapperDef methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! !Heaper subclass: #FeWrapperSpec instanceVariableNames: ' myDef {FeWrapperDef} myEndorsements {CrossRegion} myFilter {Filter} mySuperSpec {FeAbstractWrapperSpec | NULL}' classVariableNames: ' TheWrapperDefs {MuTable of: Tumbler with: FeWrapperDef} TheWrapperEndorsements {MuTable of: Tumbler with: CrossRegion} TheWrappersFromEndorsements {MuTable of: Tuple with: FeWrapperSpec} TheWrapperSpecs {MuTable of: Tumbler with: FeWrapperSpec} ' poolDictionaries: '' category: 'Xanadu-wrapper'! FeWrapperSpec comment: 'Handles wrapping, certification, and filtering for a wrapper type and its subtypes (if there are any)'! (FeWrapperSpec getOrMakeCxxClassDescription) friends: '/* friends for class FeWrapperSpec */ friend class FeWrapper; '; attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; add: #EQ; yourself)! !FeWrapperSpec methodsFor: 'accessing'! {BooleanVar} certify: edition {FeEdition} "Whether the Edition passes the invariants of this type so that it could be certified. Always checks the actual contents and endorses if they are acceptable." self subclassResponsibility! {Filter CLIENT} filter "A filter which selects for Editions which have been endorsed as belonging to this type." myFilter == NULL ifTrue: [myFilter := CurrentGrandMap fluidGet endorsementFilterSpace emptyRegion cast: Filter]. ^myFilter! {BooleanVar} isCertified: edition {FeEdition} "Whether an Edition is already endorsed as being of this type. Equivalent to this->filter ()->match (edition->endorsements ())" ^self filter match: edition endorsements! {Sequence CLIENT} name "The name for this type" ^myDef name! {FeWrapper CLIENT} wrap: edition {FeEdition} "The Edition wrapped with my type of Wrapper. If it does not have endorsements, will attempt to certify. Blasts if there is more than one valid wrapping." | result {FeWrapper} | result := self fetchWrap: edition. result == NULL ifTrue: [Heaper BLAST: #CannotWrap]. ^result! ! !FeWrapperSpec methodsFor: 'vulnerable'! {FeWrapper | NULL} fetchWrap: edition {FeEdition} self subclassResponsibility! {BooleanVar} isSubSpecOf: other {FeWrapperSpec} "Whether this is the same as or a kind of the other spec" ^self == other or: [(other isKindOf: FeAbstractWrapperSpec) and: [self fetchSuperSpec ~~ NULL and: [self fetchSuperSpec isSubSpecOf: other]]]! ! !FeWrapperSpec methodsFor: 'protected:'! {void} addToFilter: endorsements {CrossRegion} "Add some more endorsements to filter for" myFilter := (self filter unionWith: (CurrentGrandMap fluidGet endorsementFilterSpace anyFilter: endorsements)) cast: Filter! {FeWrapperDef} def ^myDef! {FeAbstractWrapperSpec | NULL} fetchSuperSpec "The immediate supertype, or NULL if this is the generic Wrapper type" ^mySuperSpec! {void} setup "Do the required setup for this spec in the context of a table of all known specs" (mySuperSpec == NULL and: [myDef fetchSuperDefName ~~ NULL]) ifTrue: [ | end {CrossRegion} | mySuperSpec := (FeWrapperSpec get: myDef fetchSuperDefName) cast: FeAbstractWrapperSpec. myDef setSpec: self. end := FeWrapperSpec getEndorsements: self name. myEndorsements := (self endorsements unionWith: end) cast: CrossRegion. self addToFilter: end].! ! !FeWrapperSpec methodsFor: 'create'! create: def {FeWrapperDef} super create. myDef := def. myEndorsements := NULL. myFilter := NULL. mySuperSpec := NULL.! ! !FeWrapperSpec methodsFor: 'for wrappers only'! {void} endorse: edition {FeEdition} "Endorse the Edition as being of this type. Blasts if this is an abstract type. Should only be called from the code implementing the type, or code which it trusts. We may eventually add a system to enforce this." self subclassResponsibility! {CrossRegion} endorsements myEndorsements == NULL ifTrue: [myEndorsements := CurrentGrandMap fluidGet endorsementSpace emptyRegion cast: CrossRegion]. ^myEndorsements! ! !FeWrapperSpec methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FeWrapperSpec class instanceVariableNames: ''! (FeWrapperSpec getOrMakeCxxClassDescription) friends: '/* friends for class FeWrapperSpec */ friend class FeWrapper; '; attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; add: #EQ; yourself)! !FeWrapperSpec class methodsFor: 'smalltalk: macros:'! ABSTRACTWRAPPER: wrapperName {char star} with: superName {char star | NULL} with: className {Symbol} "From a dynamic initializer, register an abstract Wrapper type" self REQUIRES: Sequence. self REQUIRES: FeWrapperSpec. FeWrapperSpec registerAbstract: wrapperName with: superName with: ((Smalltalk at: className) pointerToStaticMember: #setSpec:)! DIRECTWRAPPER: wrapperName {char star} with: superName {char star} with: className {Symbol} "From a dynamic initializer, register an abstract Wrapper type" self REQUIRES: Sequence. self REQUIRES: FeWrapperSpec. FeWrapperSpec registerDirect: wrapperName with: superName with: ((Smalltalk at: className) pointerToStaticMember: #makeWrapper:) with: ((Smalltalk at: className) pointerToStaticMember: #check:) with: ((Smalltalk at: className) pointerToStaticMember: #setSpec:)! INDIRECTWRAPPER: wrapperName {char star} with: superName {char star | NULL} with: innerName {char star | NULL} with: className {Symbol} "From a dynamic initializer, register an abstract Wrapper type" self REQUIRES: Sequence. self REQUIRES: FeWrapperSpec. FeWrapperSpec registerIndirect: wrapperName with: superName with: innerName with: ((Smalltalk at: className) pointerToStaticMember: #makeWrapper:) with: ((Smalltalk at: className) pointerToStaticMember: #check:) with: ((Smalltalk at: className) pointerToStaticMember: #setSpec:)! ! !FeWrapperSpec class methodsFor: 'registering wrappers'! {void} registerAbstract: wrapperName {char star} with: superName {char star | NULL} with: holder {FeWrapperSpecHolder var | NULL} | wrapper {Sequence} superWrapper {Sequence} | wrapper := Sequence string: wrapperName. superName == NULL ifTrue: [superWrapper := NULL] ifFalse: [superWrapper := Sequence string: superName]. TheWrapperDefs at: wrapper introduce: (FeWrapperDef abstract: wrapper with: superWrapper with: holder).! {void} registerDirect: wrapperName {char star} with: superName {char star | NULL} with: maker {FeDirectWrapperMaker var} with: checker {FeDirectWrapperChecker var} with: holder {FeWrapperSpecHolder var} | wrapper {Sequence} superWrapper {Sequence} | wrapper := Sequence string: wrapperName. superName == NULL ifTrue: [superWrapper := NULL] ifFalse: [superWrapper := Sequence string: superName]. TheWrapperDefs at: wrapper introduce: (FeWrapperDef makeDirect: wrapper with: superWrapper with: holder with: maker with: checker).! {void} registerIndirect: wrapperName {char star} with: superName {char star | NULL} with: innerName {char star | NULL} with: maker {FeIndirectWrapperMaker var} with: checker {FeIndirectWrapperChecker var} with: holder {FeWrapperSpecHolder var} | wrapper {Sequence} superWrapper {Sequence} innerWrapper {Sequence} | wrapper := Sequence string: wrapperName. superName == NULL ifTrue: [superWrapper := NULL] ifFalse: [superWrapper := Sequence string: superName]. innerName == NULL ifTrue: [innerWrapper := NULL] ifFalse: [innerWrapper := Sequence string: innerName]. TheWrapperDefs at: wrapper introduce: (FeWrapperDef makeIndirect: wrapper with: superWrapper with: holder with: innerWrapper with: maker with: checker).! ! !FeWrapperSpec class methodsFor: 'exceptions: exceptions'! problems.WrapFailure ^self signals: #(CannotWrap)! ! !FeWrapperSpec class methodsFor: 'smalltalk: init'! initTimeNonInherited self REQUIRES: SequenceSpace. self REQUIRES: MuTable. TheWrapperDefs := MuTable make: SequenceSpace make.! linkTimeNonInherited TheWrapperDefs := NULL. TheWrapperSpecs := NULL. TheWrapperEndorsements := NULL. TheWrappersFromEndorsements := NULL.! ! !FeWrapperSpec class methodsFor: 'private:'! {void} mustSetup [BeGrandMap] USES. TheWrapperEndorsements == NULL ifTrue: [self setWrapperEndorsements: CurrentGrandMap fluidGet wrapperEndorsements].! ! !FeWrapperSpec class methodsFor: 'accessing'! {FeWrapperSpec | NULL} fetch: identifier {Sequence} "Get the local Wrapper spec with the given identifier, or NULL if there is none" self mustSetup. ^(TheWrapperSpecs fetch: identifier) cast: FeWrapperSpec! {FeWrapperSpec CLIENT} get: identifier {Sequence} "Get the local Wrapper spec with the given identifier, or blast if there is none" | result {FeWrapperSpec} | result := self fetch: identifier. result == NULL ifTrue: [Heaper BLAST: #NotInTable]. ^result! {CrossRegion} getEndorsements: identifier {Sequence} "Get the endorsements for the named wrapper space" self mustSetup. ^(TheWrapperEndorsements get: identifier) cast: CrossRegion! {FeWrapperSpec} getFromEndorsement: endorsement {Tuple} "Get the wrapper spec corresponding to the given endorsement" self mustSetup. ^(TheWrappersFromEndorsements get: endorsement) cast: FeWrapperSpec! {XnRegion of: Sequence} knownWrappers "The names of all of the known wrappers" ^TheWrapperDefs domain! {void} setupWrapperSpecs "Get the local Wrapper spec with the given identifier, or NULL if there is none" TheWrapperSpecs := MuTable make: SequenceSpace make. TheWrapperDefs stepper forEach: [ :def {FeWrapperDef} | TheWrapperSpecs at: def name introduce: def makeSpec]. TheWrapperSpecs stepper forEach: [ :spec {FeWrapperSpec} | spec setup].! {void} setWrapperEndorsements: endorsements {ScruTable of: Sequence with: CrossRegion} "A table mapping from wrapper names to endorsements" TheWrapperEndorsements := endorsements asMuTable. self setupWrapperSpecs. TheWrappersFromEndorsements := MuTable make: CurrentGrandMap fluidGet endorsementSpace. endorsements stepper forPositions: [ :seq {Sequence} :endorses {CrossRegion} | endorses isFinite ifFalse: [Heaper BLAST: #FatalError]. Ravi thingToDo. "implement stepper so that endorsements are allowed to be regions" TheWrappersFromEndorsements at: endorses theOne introduce: (self get: seq) "endorses stepper forEach: [ :endorse {Tuple} | TheWrappersFromEndorsements at: endorse introduce: (self get: seq)]"].! ! !FeWrapperSpec class methodsFor: 'smalltalk: system'! info.stProtocol "{Filter CLIENT} filter {Sequence CLIENT} name {FeWrapper CLIENT} wrap: edition {FeEdition} "! !FeWrapperSpec subclass: #FeAbstractWrapperSpec instanceVariableNames: 'myConcreteSpecs {PtrArray of: FeConcreteWrapperSpec}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-wrapper'! (FeAbstractWrapperSpec getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !FeAbstractWrapperSpec methodsFor: 'accessing'! {BooleanVar} certify: edition {FeEdition} Int32Zero almostTo: myConcreteSpecs count do: [ :i {Int32} | (((myConcreteSpecs fetch: i) cast: FeConcreteWrapperSpec) certify: edition) ifTrue: [^true]]. ^false! {void} setupConcreteSubSpec: spec {FeConcreteWrapperSpec} "Add a new concrete spec to the list, keeping it topologically sorted so that if A wraps B, A precedes B" | pos {Int32} copy {PtrArray of: FeConcreteWrapperSpec} | "remember its endorsements" self addToFilter: spec endorsements. "Look for the last wrapper in the array that can wrap this one" pos := myConcreteSpecs count. [(pos <= Int32Zero or: [((myConcreteSpecs fetch: pos - 1) cast: FeConcreteWrapperSpec) wraps: spec]) not] whileTrue: [pos := pos - 1]. "Make a copy and insert it just after that one" copy := (myConcreteSpecs copyGrow:1) cast: PtrArray. copy count - 1 downTo: pos + 1 do: [ :j {Int32} | copy at: j store: (copy fetch: j - 1)]. copy at: pos store: spec. myConcreteSpecs := copy. "Recur upwards to add the spec to my parent" self setup. self fetchSuperSpec ~~ NULL ifTrue: [self fetchSuperSpec setupConcreteSubSpec: spec]! ! !FeAbstractWrapperSpec methodsFor: 'create'! create: def {FeAbstractWrapperDef} super create: def. myConcreteSpecs := PtrArray empty! ! !FeAbstractWrapperSpec methodsFor: 'for wrappers only'! {void} endorse: edition {FeEdition unused} Heaper BLAST: #MustBeConcreteWrapperSpec! ! !FeAbstractWrapperSpec methodsFor: 'vulnerable'! {FeWrapper | NULL} fetchWrap: edition {FeEdition} | sub {FeConcreteWrapperSpec} result {FeWrapper} | Ravi thingToDo. "BLAST if there is an ambiguity; right now the only possible one is between an empty Path and and an empty Text" "If there are any endorsements that match mine, pick a concrete type that isn't wrapped by anything else" sub := NULL. (edition endorsements intersect: self endorsements) stepper forEach: [ :end {Tuple} | | other {FeConcreteWrapperSpec} | other := (FeWrapperSpec getFromEndorsement: end) cast: FeConcreteWrapperSpec. (sub == NULL or: [other wraps: sub]) ifTrue: [sub := other]]. sub ~~ NULL ifTrue: [^sub fetchWrap: edition]. "There are no endorsements. Just walk through the topological sort until you hit one which works" Int32Zero almostTo: myConcreteSpecs count do: [ :i {Int32} | (myConcreteSpecs fetch: i) cast: FeConcreteWrapperSpec into: [ :spec | result := spec fetchWrap: edition. result ~~ NULL ifTrue: [^result]]]. ^NULL! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FeAbstractWrapperSpec class instanceVariableNames: ''! (FeAbstractWrapperSpec getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !FeAbstractWrapperSpec class methodsFor: 'pseudo constructors'! make: def {FeAbstractWrapperDef} ^self create: def! !FeWrapperSpec subclass: #FeConcreteWrapperSpec instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-wrapper'! (FeConcreteWrapperSpec getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !FeConcreteWrapperSpec methodsFor: 'protected:'! {void} setup super setup. self fetchSuperSpec ~~ NULL ifTrue: [self fetchSuperSpec setupConcreteSubSpec: self].! ! !FeConcreteWrapperSpec methodsFor: 'accessing'! {BooleanVar} certify: edition {FeEdition} self subclassResponsibility! {BooleanVar} wraps: other {FeConcreteWrapperSpec} "Whether I can wrap the given type" self subclassResponsibility! ! !FeConcreteWrapperSpec methodsFor: 'create'! create: def {FeWrapperDef} super create: def! ! !FeConcreteWrapperSpec methodsFor: 'for wrappers only'! {void} endorse: edition {FeEdition} "Endorse an Edition as being of this type" [BeEdition] USES. edition beEdition endorse: self endorsements! ! !FeConcreteWrapperSpec methodsFor: 'vulnerable'! {FeWrapper | NULL} fetchWrap: edition {FeEdition} self subclassResponsibility! !FeConcreteWrapperSpec subclass: #FeDirectWrapperSpec instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-wrapper'! (FeDirectWrapperSpec getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !FeDirectWrapperSpec methodsFor: 'accessing'! {BooleanVar} wraps: other {FeConcreteWrapperSpec} ^self == other! ! !FeDirectWrapperSpec methodsFor: 'private:'! {BooleanVar} certify: edition {FeEdition} "Try to certify as this type. If successful, return TRUE and endorse it; if not, return FALSE." ((self def cast: FeDirectWrapperDef) check: edition) ifTrue: [self endorse: edition. ^true] ifFalse: [^false]! ! !FeDirectWrapperSpec methodsFor: 'create'! create: def {FeDirectWrapperDef} super create: def! ! !FeDirectWrapperSpec methodsFor: 'vulnerable'! {FeWrapper} fetchWrap: edition {FeEdition} ((self isCertified: edition) or: [self certify: edition]) ifTrue: [^(self def cast: FeDirectWrapperDef) makeWrapper: edition] ifFalse: [^NULL]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FeDirectWrapperSpec class instanceVariableNames: ''! (FeDirectWrapperSpec getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !FeDirectWrapperSpec class methodsFor: 'pseudo constructors'! make: def {FeDirectWrapperDef} ^self create: def! !FeConcreteWrapperSpec subclass: #FeIndirectWrapperSpec instanceVariableNames: 'myInner {FeConcreteWrapperSpec}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-wrapper'! (FeIndirectWrapperSpec getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !FeIndirectWrapperSpec methodsFor: 'accessing'! {BooleanVar} wraps: other {FeConcreteWrapperSpec} ^self == other or: [myInner wraps: other]! ! !FeIndirectWrapperSpec methodsFor: 'private:'! {BooleanVar} certify: inner {FeEdition} "Try to certify as this type. If successful, return TRUE and endorse it; if not, return FALSE." (self indirectDef check: inner) ifTrue: [self endorse: inner. ^true] ifFalse: [^false]! {FeIndirectWrapperDef} indirectDef ^self def cast: FeIndirectWrapperDef! ! !FeIndirectWrapperSpec methodsFor: 'protected:'! {void} setup super setup. myInner := (FeWrapperSpec get: self indirectDef innerDefName) cast: FeConcreteWrapperSpec! ! !FeIndirectWrapperSpec methodsFor: 'create'! create: def {FeIndirectWrapperDef} super create: def. myInner := NULL.! ! !FeIndirectWrapperSpec methodsFor: 'vulnerable'! {FeWrapper | NULL} fetchWrap: edition {FeEdition} | inner {FeWrapper} | inner := myInner wrap: edition. ((self isCertified: edition) or: [self certify: edition]) ifTrue: [^self indirectDef makeWrapper: edition with: inner]. ^NULL! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FeIndirectWrapperSpec class instanceVariableNames: ''! (FeIndirectWrapperSpec getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !FeIndirectWrapperSpec class methodsFor: 'pseudo constructors'! make: def {FeIndirectWrapperDef} ^self create: def! !XnExecutor subclass: #FillDetectorExecutor instanceVariableNames: 'myPlaceHolder {BePlaceHolder}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-brange1'! FillDetectorExecutor comment: 'This class notifies its place holder when its last fill detector has gone away.'! (FillDetectorExecutor getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !FillDetectorExecutor methodsFor: 'protected: create'! create: placeHolder {BePlaceHolder} super create. myPlaceHolder := placeHolder.! ! !FillDetectorExecutor methodsFor: 'execute'! {void} execute: arg {Int32} arg == Int32Zero ifTrue: [ myPlaceHolder removeLastDetector]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FillDetectorExecutor class instanceVariableNames: ''! (FillDetectorExecutor getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !FillDetectorExecutor class methodsFor: 'create'! {XnExecutor} make: placeHolder {BePlaceHolder} ^ self create: placeHolder! !Heaper subclass: #FlockLocation instanceVariableNames: ' mySnarfID {SnarfID} myIndex {Int4}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Snarf'! FlockLocation comment: 'Represent the location of a flock on disk. This ID of the snarf in which the flock is contained, and the index of the flock within that snarf. This information side-effect free, even in subclasses.'! (FlockLocation getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; yourself)! !FlockLocation methodsFor: 'protected: accessing'! {void} index: anIndex {Int32} "This is used to set the index when a flock is bumped from its snarf and forwarded by way of the new flocks table" myIndex := anIndex! ! !FlockLocation methodsFor: 'accessing'! {Int32 INLINE} index ^myIndex! {SnarfID INLINE} snarfID ^mySnarfID! ! !FlockLocation methodsFor: 'creation'! create: snarfID {SnarfID} with: index {Int32} super create. mySnarfID _ snarfID. myIndex _ index! ! !FlockLocation methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '(' << mySnarfID <<', ' << myIndex << ')'! ! !FlockLocation methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FlockLocation class instanceVariableNames: ''! (FlockLocation getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; yourself)! !FlockLocation class methodsFor: 'creation'! make: snarfID {SnarfID} with: index {Int32} ^self create: snarfID with: index! !FlockLocation subclass: #FlockInfo instanceVariableNames: ' myFlockHash {UInt4} myToken {Int32} myFlags {UInt32} myOldSize {Int32}' classVariableNames: 'TheFlockCategoryTable {PrimPtrTable smalltalk} ' poolDictionaries: '' category: 'Xanadu-Snarf'! FlockInfo comment: 'Contains all the information the packer needs to know about the flock on disk (except forwarder stuff). The packer knows about forwarders by having several FlockInfo objects for the same flock. We should consider having a separate class for forward information that does not contain the flags and the oldSize. myOldSize - this is the size of the flock on disk as of the last commit. If this is zero, it is uninitialized. This is used to refitting without bringing in the snarf for this flock. myFlags - keeps track of whether the receive is a new flock (isn''t on disk yet), is forgotten, is in the process is fchanging its forggten state (isChanging), and is Update (contents have changed).'! (FlockInfo getOrMakeCxxClassDescription) friends: ' friend UInt4 contentsDirty (); friend UInt4 forgottenMask (); friend UInt4 forgottenStateDirty (); friend UInt4 isNewMask (); '; attributes: ((Set new) add: #CONCRETE; yourself)! !FlockInfo methodsFor: 'testing'! {BooleanVar} isContentsDirty "Return true if my shepherd has changed and informed the SnarfPacker." ^(myFlags bitAnd: FlockInfo contentsDirty) ~~ UInt32Zero! {BooleanVar} isDestroyed "Return true if our shepherd has received destroy" ^(myFlags bitAnd: FlockInfo destroyed) ~~ UInt32Zero.! {BooleanVar} isDirty "Return true if anything about my flock is changing (including if the flock is new)." ^(myFlags bitAnd: ((FlockInfo isNewMask bitOr: FlockInfo contentsDirty) bitOr: FlockInfo forgottenStateDirty)) ~~ UInt32Zero! {BooleanVar} isDismantled "Return true if our shepherd has been dismantled" ^(myFlags bitAnd: FlockInfo dismantled) ~~ UInt32Zero.! {BooleanVar} isForgotten "Return true if my Shepherd's new state is it should be forgotten." ^self wasForgotten ~~ self isForgottenStateDirty! {BooleanVar} isForgottenStateDirty "Return true if the shepherd I describe is changing between being forgotten and being remembered." ^(myFlags bitAnd: FlockInfo forgottenStateDirty) ~~ UInt32Zero! {BooleanVar} isForwarded "Return true if my shepherd has been forwarded." ^(myFlags bitAnd: FlockInfo forwarded) ~~ UInt32Zero! {BooleanVar} isNew "Return true if the associated flock is new. If so, myIndex is an offset into the new flocks table inside the SnarfPacker." ^(myFlags bitAnd: FlockInfo isNewMask) ~~ UInt32Zero! {BooleanVar} wasForgotten "Return true if my shepherd was forgotten after the last commit." ^(myFlags bitAnd: FlockInfo forgottenMask) ~~ UInt32Zero! {BooleanVar} wasShepNullInPersistent "Return true if our shepherd pointer was NULL in makePersistent" ^(myFlags bitAnd: FlockInfo shepNullInPersistent) ~~ UInt32Zero.! ! !FlockInfo methodsFor: 'accessing'! {void} clearContentsDirty "Reset my contentsDirty flag. This is primarily used to know when a flock has changed again after some info has been computed from it." myFlags _ myFlags bitAnd: FlockInfo contentsDirty bitInvert! {void} commitFlags "A write to the disk has happened. Commit all the changes in the flags." self isForgottenStateDirty ifTrue: [myFlags _ myFlags bitXor: FlockInfo forgottenMask]. myFlags _ myFlags bitAnd: FlockInfo forgottenMask! {Int32} flags ^myFlags! {UInt4} flockHash ^myFlockHash! {void} forward: index {Int32} "As a freshly forwarded flock, I'll be treated as new for a while." myFlags _ myFlags bitOr: FlockInfo forwarded. self index: index.! {BooleanVar} markContentsDirty "Set my contentsDirty flag. Return false if I was already dirty (in either way)." | flag {BooleanVar} | flag _ self isDirty not. myFlags _ myFlags bitOr: FlockInfo contentsDirty. ^flag! {void} markDestroyed "Set my shepNull flag." myFlags _ myFlags bitOr: FlockInfo destroyed.! {void} markDismantled "Set my Dismantled flag. BLAST if already set." self isDismantled not assert: 'Already dismantled'. myFlags _ myFlags bitOr: FlockInfo dismantled.! {BooleanVar} markForgotten "Set my Forgotten flag. Return false if I was already dirty." | flag {BooleanVar} | flag _ self isDirty not. self isForgotten not ifTrue: [myFlags _ myFlags bitXor: FlockInfo forgottenStateDirty]. ^flag! {BooleanVar} markRemembered "Clear my Forgotten flag. Return false if I was already dirty." | flag {BooleanVar} | flag _ self isDirty not. self isForgotten ifTrue: [myFlags _ myFlags bitXor: FlockInfo forgottenStateDirty]. ^flag! {void} markShepNull "Set my shepNull flag." myFlags _ myFlags bitOr: FlockInfo shepNullInPersistent.! {Int32} oldSize ^myOldSize! {void} setSize: size {Int32} myOldSize _ size! ! !FlockInfo methodsFor: 'tokens'! {Abraham} fetchShepherd myToken == nil ifTrue: [^NULL]. myToken == -1 ifTrue: [ [self halt]smalltalkOnly. ^ NULL ] ifFalse: [ ^Abraham fetchShepherd: myToken]! {Abraham} getShepherd | shep {Abraham} | shep := self fetchShepherd. shep == NULL ifTrue: [ Heaper BLAST: #NullShepherd ]. ^ shep! {void} registerInfo "Register this info as the best known informatino about the flock." CurrentPacker fluidGet flockInfoTable at: myToken store: self. [| cat shep | shep _ self getShepherd. [shep == nil ifTrue: [self halt]]smalltalkOnly. shep isStub ifTrue: [cat _ shep getCategoryFromStub] ifFalse: [cat _ shep getCategory]. TheFlockCategoryTable at: myToken store: cat] smalltalkOnly! {Int32} token [myToken == nil ifTrue: [self halt]] smalltalkOnly. ^myToken! ! !FlockInfo methodsFor: 'create'! create: shep {Abraham} with: snarfID {SnarfID} with: index {Int32} with: flags {Int32} with: size {Int32} super create: snarfID with: index. myFlockHash _ shep hashForEqual. myToken _ shep token. [myToken == nil ifTrue:[self halt]]smalltalkOnly. myFlags _ flags. myOldSize _ size. [shep == NULL ifTrue:[self halt] ]smalltalkOnly! ! !FlockInfo methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '('. self isContentsDirty ifTrue: [oo << 'D']. self isNew ifTrue: [oo << 'N']. self isDestroyed ifTrue: [oo << 'X' "X for Xtinct"]. self isDismantled ifTrue: [oo << 'Z' "Z for zapped"]. self wasForgotten ifTrue: [oo << '-'] ifFalse: [oo << '+']. self isForgotten ifTrue: [oo << '-'] ifFalse: [oo << '+']. oo << ', ' << self snarfID << ', ' << self index << ', ' << myOldSize << ')'! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FlockInfo class instanceVariableNames: ''! (FlockInfo getOrMakeCxxClassDescription) friends: ' friend UInt4 contentsDirty (); friend UInt4 forgottenMask (); friend UInt4 forgottenStateDirty (); friend UInt4 isNewMask (); '; attributes: ((Set new) add: #CONCRETE; yourself)! !FlockInfo class methodsFor: 'creation'! {FlockInfo} forgotten: shep {Abraham} with: snarfID {SnarfID} with: index {Int32} ^ self create: shep with: snarfID with: index with: FlockInfo forgottenMask with: Int32Zero.! make: shep {Abraham} with: index {IntegerVar} "Make a ShepherdLocation for a new shepherd. Index is the index into the new flocks table in the snarfPacker. The newmask indicates that the index is into the newFlocks table rather than a snarf." ^ self create: shep with: Int32Zero with: index DOTasLong with: (((FlockInfo contentsDirty bitOr: FlockInfo forgottenStateDirty) bitAnd: FlockInfo forgottenMask bitInvert) bitOr: FlockInfo isNewMask) with: Int32Zero.! make: info {FlockInfo} with: snarfID {SnarfID} with: index {Int32} "Make a flockInfo to a new location for the same shepherd. Clear the new flag, and keep the rest the same." ^self create: info getShepherd with: snarfID with: index with: (info flags bitAnd: FlockInfo isNewMask bitInvert) with: info oldSize! {FlockInfo} remembered: shep {Abraham} with: snarfID {SnarfID} with: index {Int32} ^ self create: shep with: snarfID with: index with: UInt32Zero with: Int32Zero.! ! !FlockInfo class methodsFor: 'debugging tools'! {BooleanVar} testContentsDirty: info {FlockInfo} ^info isContentsDirty! {BooleanVar} testForgotten: info {FlockInfo} ^info isForgotten! ! !FlockInfo class methodsFor: 'testing flags'! {UInt32 INLINE} contentsDirty ^ 4! {UInt32 INLINE} destroyed ^ 16! {UInt32 INLINE} dismantled ^ 32! {UInt32 INLINE} forgottenMask ^ 1! {UInt32 INLINE} forgottenStateDirty ^ 2! {UInt32 INLINE} forwarded ^ 128! {UInt32 INLINE} isNewMask ^ 8! {UInt32 INLINE} shepNullInPersistent ^ 64! ! !FlockInfo class methodsFor: 'smalltalk: initialization'! staticTimeNonInherited [TheFlockCategoryTable _ PrimPtrTable make: 2048] smalltalkOnly! ! !FlockInfo class methodsFor: 'flock tables'! {FlockInfo} getInfo: index {Int32} [DiskManager] USES. ^ (CurrentPacker fluidGet flockInfoTable get: index) cast: FlockInfo! {void} removeInfo: token {Int32} CurrentPacker fluidGet flockInfoTable remove: token. "Abraham returnToken: token"! !FlockInfo subclass: #TestFlockInfo instanceVariableNames: ' myOldHash {UInt32} myPreviousHash {UInt32} myOldContents {UInt8Array}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Snarf'! TestFlockInfo comment: 'Used in conjunction with the TestPacker. Keeps a hash of the last contents that were written to disk.'! (TestFlockInfo getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !TestFlockInfo methodsFor: 'create'! create: shep {Abraham} with: snarfID {SnarfID} with: index {Int32} with: flags {UInt32} super create: shep with: snarfID with: index with: flags with: Int32Zero. myOldHash := UInt32Zero. myPreviousHash := UInt32Zero. myOldContents := NULL! create: shep {Abraham} with: snarfID {SnarfID} with: index {Int32} with: flags {Int32} with: size {Int32} super create: shep with: snarfID with: index with: flags with: size. myOldHash := UInt32Zero. myPreviousHash := UInt32Zero. myOldContents := NULL! ! !TestFlockInfo methodsFor: 'accessing'! {void} setContents: bits {UInt8Array} myOldContents := bits! {BooleanVar} updateContentsInfo "Update the contents hash and other information from the current state of the shepherd. Return true if the HASH only has changed since the last time." myPreviousHash := myOldHash. self fetchShepherd == NULL ifTrue: [myOldHash := UInt32Zero] ifFalse: [myOldHash := (CurrentPacker fluidGet cast: TestPacker) computeHash: self getShepherd]. ^myPreviousHash ~= myOldHash! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TestFlockInfo class instanceVariableNames: ''! (TestFlockInfo getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !TestFlockInfo class methodsFor: 'pseudo constructors'! {FlockInfo} forgotten: shep {Abraham} with: snarfID {SnarfID} with: index {Int32} "index = UInt32Zero assert: 'Should have index 0'." ^self create: shep with: snarfID with: index with: FlockInfo forgottenMask! {FlockInfo} make: shep {Abraham} with: index {IntegerVar} "index = UInt32Zero assert: 'Should have index 0'." ^self create: shep with: Int32Zero with: index DOTasLong with: (((FlockInfo contentsDirty bitOr: FlockInfo forgottenStateDirty) bitAnd: FlockInfo forgottenMask bitInvert) bitOr: FlockInfo isNewMask)! {FlockInfo} make: info {FlockInfo} with: snarfID {SnarfID} with: index {Int32} "index = UInt32Zero assert: 'Should have index 0'." ^self create: info getShepherd with: snarfID with: index with: (info flags bitAnd: FlockInfo isNewMask bitInvert) with: info oldSize! {FlockInfo} remembered: shep {Abraham} with: snarfID {SnarfID} with: index {Int32} index = UInt32Zero assert: 'Should have index 0'. ^self create: shep with: snarfID with: index with: UInt32Zero! !Heaper subclass: #HashSetCache instanceVariableNames: ' mySize {UInt32} myElements {PtrArray}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Cache'! (HashSetCache getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; add: #COPY; yourself)! !HashSetCache methodsFor: 'accessing'! {BooleanVar} hasMember: aHeaper {Heaper} | index {UInt32 register} val {Heaper | NULL} | index _ aHeaper hashForEqual \\ mySize. (index < UInt32Zero or: [index >= mySize]) ifTrue: [Heaper BLAST: #ModuloFailed]. val _ myElements fetch: index. ^val ~~ NULL and: [aHeaper isEqual: val]! {void} store: aHeaper {Heaper} | index {UInt32 register} | index _ aHeaper hashForEqual \\ mySize. (index < UInt32Zero or: [index >= mySize]) ifTrue: [Heaper BLAST: #ModuloFailed]. myElements at: index store: aHeaper! {void} wipe: aHeaper {Heaper} | index {UInt32 register} val {Heaper | NULL} | index _ aHeaper hashForEqual \\ mySize. (index < UInt32Zero or: [index >= mySize]) ifTrue: [Heaper BLAST: #ModuloFailed]. val _ myElements fetch: index. (val ~~ NULL and: [aHeaper isEqual: val]) ifTrue: [myElements at: index store: NULL]! ! !HashSetCache methodsFor: 'create/delete'! create: size {UInt32} super create. mySize _ size. myElements _ PtrArray nulls: mySize! ! !HashSetCache methodsFor: 'protected: creation'! {void} destruct myElements _ NULL. mySize _ UInt32Zero. super destruct! ! !HashSetCache methodsFor: 'generated:'! actualHashForEqual ^self asOop! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. mySize _ receiver receiveUInt32. myElements _ receiver receiveHeaper.! isEqual: other ^self == other! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendUInt32: mySize. xmtr sendHeaper: myElements.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HashSetCache class instanceVariableNames: ''! (HashSetCache getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; add: #COPY; yourself)! !HashSetCache class methodsFor: 'pseudo-constructors'! make ^self create: 10! make: size {UInt32} ^self create: size! !Heaper subclass: #Heaper2UInt32Cache instanceVariableNames: ' myKeys {PtrArray} myValues {UInt32Array} myEmptyValue {UInt32}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-canopy'! Heaper2UInt32Cache comment: 'Caches a mapping from Heapers (using isEqual / hashForEqual) to UInt32s. Returns myEmptyValue if there is no cached mapping.'! (Heaper2UInt32Cache getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; yourself)! !Heaper2UInt32Cache methodsFor: 'accessing'! {void} at: key {Heaper} cache: value {UInt32} "Cache a value for a key" | index {Int32} | index := key hashForEqual \\ myKeys count. myKeys at: index store: key. myValues at: index storeUInt: value.! {UInt32} fetch: key {Heaper} "Return the cached value for the key, or my empty value if there is none" | index {Int32} k {Heaper} | index := key hashForEqual \\ myKeys count. k := myKeys fetch: index. (k ~~ NULL and: [k == key or: [k isEqual: key]]) ifTrue: [^myValues uIntAt: index] ifFalse: [^myEmptyValue]! {UInt32} get: key {Heaper} "Return the cached value for the key, or BLAST if there is none" | index {Int32} k {Heaper} | index := key hashForEqual \\ myKeys count. k := myKeys fetch: index. (k ~~ NULL and: [k == key or: [k isEqual: key]]) ifFalse: [Heaper BLAST: #NotInTable]. ^myValues uIntAt: index! ! !Heaper2UInt32Cache methodsFor: 'create'! create: count {Int32} with: empty {UInt32} super create. myKeys := PtrArray nulls: count. myValues := UInt32Array make: count. myEmptyValue := empty. empty ~~ UInt32Zero ifTrue: [myValues storeAll: (PrimIntValue make: empty)]! ! !Heaper2UInt32Cache methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Heaper2UInt32Cache class instanceVariableNames: ''! (Heaper2UInt32Cache getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; yourself)! !Heaper2UInt32Cache class methodsFor: 'smalltalk: defaults'! make: n ^self make: n with: 0! ! !Heaper2UInt32Cache class methodsFor: 'create'! make: count {Int32} with: empty {UInt32 default: UInt32Zero} ^self create: (PrimeSizeProvider make uInt32PrimeAfter: count) with: empty! ! !Heaper2UInt32Cache class methodsFor: 'smalltalk: init'! initTimeNonInherited self REQUIRES: PrimArray. self REQUIRES: PrimeSizeProvider.! !Heaper subclass: #HistoryCrum instanceVariableNames: 'myHash {UInt32}' classVariableNames: 'SequenceNumber {UInt32} ' poolDictionaries: '' category: 'Xanadu-Be-Ents'! HistoryCrum comment: 'invariant: the parent''s trace >= the child''s trace The subclasses should differentiate between the number of children: 0, 1, or more. ORoots have 0 children and always have a canopyCrum. HCrums for OCrums in the body of the ent have one child if they are at the top of an unshared subtreee, and more if they are at the top of a shared subtree. HCrums with more than one child almost always have a canopyCrum to represent the join between the canopies of their multiple hchildren. The change would make the updateH method return a new crum, which the oCrums would install. They don''t do so now because I''m not sure if a crum with no parents can appear in the middle of the ent. If so, then the version compare operations would gag. Hmmm. The change doesn''t make any difference for that....'! (HistoryCrum getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #COPY; yourself)! !HistoryCrum methodsFor: 'smalltalk:'! displayString self hCut printString! inspect Sensor leftShiftDown ifTrue: [self basicInspect] ifFalse: [EntView openOn: (TreeBarnacle new buildOn: self gettingChildren: [:htree | htree oParents asOrderedCollection collect: [:hc | hc hCrum]] gettingImage: [:htree | htree printString asDisplayText] at: 0 @ 0 vertical: true separation: 5 @ 10)]! inspectCanopy self bertCrum inspect! inspectMenuArray ^#( ('inspect orgls' inspectOrgls '') ('bert canopy' inspectCanopy ''))! inspectOrgls self subclassResponsibility! {void} printOn: aStream {ostream reference} aStream << self getCategory name << '(' << self hCut << ')'! showOn: oo oo << self hCut << ', ' << self asOop! ! !HistoryCrum methodsFor: 'deferred filtering'! {void} actualDelayedStoreBackfollow: finder {PropFinder} with: fossil {RecorderFossil} with: recorder {ResultRecorder} with: hCrumCache {HashSetCache of: HistoryCrum} "See comment in HistoryCrum>>delayedStoreBackfollow:with:with:" self subclassResponsibility! {BooleanVar} anyPasses: finder {PropFinder} self subclassResponsibility! {BertCrum} bertCrum "These objects must have a crum in the bert canopy." self subclassResponsibility! ! !HistoryCrum methodsFor: 'filtering'! {void} delayedStoreBackfollow: finder {PropFinder} with: fossil {RecorderFossil} with: recorder {ResultRecorder} with: hCrumCache {HashSetCache of: HistoryCrum} "Do the northward H-tree walk for the 'now' part of a backfollow." || "Check cache, call polymorphic actualDelayedStoreBackfollow if miss." (hCrumCache hasMember: self) not ifTrue: [hCrumCache store: self. self actualDelayedStoreBackfollow: finder with: fossil with: recorder with: hCrumCache]! {void} ringDetectors: edition {FeEdition} "Ring all the detectors north of me with the given Edition as argument" self subclassResponsibility! ! !HistoryCrum methodsFor: 'testing'! {UInt32} actualHashForEqual ^myHash! {BooleanVar} isEmpty "Return true if their are no upward pointers. This is used by OParts to determine if they can be forgotten." self subclassResponsibility! {BooleanVar} isEqual: other {Heaper} ^self == other! ! !HistoryCrum methodsFor: 'create'! create super create. myHash _ HistoryCrum nextHistoryCrumSequenceNumber.! ! !HistoryCrum methodsFor: 'deferred testing'! {Boolean} inTrace: trace {TracePosition} "Return true if the receiver can backfollow to trace." self subclassResponsibility! ! !HistoryCrum methodsFor: 'deferred accessing'! {TracePosition} hCut self subclassResponsibility! {Mapping} mappingTo: trace {TracePosition} with: initial {Mapping} "return the mapping into the domain space of the given trace" self subclassResponsibility! {ImmuSet of: OPart} oParents self subclassResponsibility! ! !HistoryCrum methodsFor: 'deferred updating'! {Boolean} propagateBCrum: newBCrum {BertCrum} "If bertCrum is leafward of newBCrum then change it and return true, otherwise return false." self subclassResponsibility! ! !HistoryCrum methodsFor: 'smalltalk: passe'! {void} actualDelayedStoreBackfollow: finder {PropFinder} with: recorder {RecorderFossil} with: hCrumCache {HashSetCache of: HistoryCrum} self passe "extra argument"! {void} actualStoreBackfollow: finder {PropFinder} with: table {MuTable of: ID and: BeEdition} with: hCrumCache {HashSetCache of: HistoryCrum} self passe! {void} delayedStoreBackfollow: finder {PropFinder} with: recorder {RecorderFossil} with: hCrumCache {HashSetCache of: HistoryCrum} self passe "extra argument"! {ImmuSet of: OPart} hCrums self passe. "use oParents"! {void} storeBackfollow: finder {PropFinder} with: table {MuTable of: ID and: BeEdition} with: hCrumCache {HashSetCache of: HistoryCrum} self passe! ! !HistoryCrum methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myHash _ receiver receiveUInt32.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendUInt32: myHash.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HistoryCrum class instanceVariableNames: ''! (HistoryCrum getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #COPY; yourself)! !HistoryCrum class methodsFor: 'smalltalk: initialization'! linkTimeNonInherited SequenceNumber _ UInt32Zero! ! !HistoryCrum class methodsFor: 'accessing'! {UInt32} nextHistoryCrumSequenceNumber "Shepherds use a sequence number for their hash. Return the next one and increment. This should actually do spread the hashes." "This actually needs to roll over the UInt32 limit." SequenceNumber _ SequenceNumber + 1 bitAnd: 134217727 "2^27-1". ^SequenceNumber! !HistoryCrum subclass: #HBottomCrum instanceVariableNames: ' myTrace {TracePosition} myBertCrum {BertCrum} myEditions {MuSet of: BeEditions}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Ents'! (HBottomCrum getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !HBottomCrum methodsFor: 'testing'! {BooleanVar} hasRefs "Return true if there are stamps that point at this orgl." ^myEditions isEmpty not! {Boolean} inTrace: trace {TracePosition} "Return true if the receiver can backfollow to trace." Dean hack. "The following grotesque hack (myEdition isEmpty not) is so that intermediate orglRoots generated by copy and combine are not considered for version comparison. The proper thing to do is make those operations destroy their intermediate results." ^(myTrace basicCast: Heaper star) == trace and: [myEditions isEmpty not]! {BooleanVar} isEmpty "Return true if their are no upward pointers. This is used by OParts to determine if they can be forgotten." ^myEditions isEmpty! {Boolean} propagateBCrum: newBCrum {BertCrum} "If bertCrum is leafward of newBCrum then change it and return true, otherwise return false." (myBertCrum isLE: newBCrum) ifTrue: [^false] ifFalse: [myBertCrum _ newBCrum. ^true]! ! !HBottomCrum methodsFor: 'accessing'! {TracePosition} hCut ^myTrace! {Mapping} mappingTo: trace {TracePosition} with: initial {Mapping} "return the mapping into the domain space of the given trace" (self inTrace: trace) ifTrue: [^initial] ifFalse: [^Mapping make: initial coordinateSpace with: initial rangeSpace]! {ImmuSet of: OPart} oParents ^ImmuSet make! ! !HBottomCrum methodsFor: 'filtering'! {void} actualDelayedStoreBackfollow: finder {PropFinder} with: fossil {RecorderFossil} with: recorder {ResultRecorder} with: hCrumCache {HashSetCache of: HistoryCrum} (myEditions isEmpty not and: [finder doesPass: myBertCrum]) ifTrue: [myEditions stepper forEach: [:edition {BeEdition} | recorder delayedStoreBackfollow: edition with: finder with: fossil with: hCrumCache]]! {BooleanVar} anyPasses: finder {PropFinder} (finder doesPass: myBertCrum) ifTrue: [myEditions stepper forEach: [:edition {BeEdition} | (edition anyPasses: finder) ifTrue: [^true]]]. ^false! {BertCrum} bertCrum ^myBertCrum! {void} introduceEdition: edition {BeEdition} myEditions introduce: edition. (self propChanger: PropChange bertPropChange) schedule! {AgendaItem} propChanger: change {PropChange} "NOTE: The AgendaItem returned is not yet scheduled. Doing so is up to my caller." | newProp {Prop} | newProp _ BertProp make. myEditions stepper forEach: [:edition {BeEdition} | newProp _ change with: newProp with: edition prop]. ^myBertCrum propChanger: change with: newProp! {void} removeEdition: edition {BeEdition} myEditions remove: edition. (self propChanger: PropChange bertPropChange) schedule! {void} ringDetectors: edition {FeEdition} self bertCrum isSensorWaiting ifTrue: [myEditions stepper forEach: [ :ed {BeEdition} | ed ringDetectors: edition]]! ! !HBottomCrum methodsFor: 'create'! create: trace {TracePosition} with: canopy {BertCrum} super create. myTrace _ trace. myBertCrum _ canopy. myBertCrum addPointer: self. myEditions _ MuSet make! ! !HBottomCrum methodsFor: 'smalltalk:'! inspectOrgls (myStamps == NULL or: [myStamps isEmpty]) ifTrue: [^Transcript show: 'Nobody'; cr; endEntry]. myStamps count == 1 ifTrue: [myStamps stepper fetch orglRoot inspect] ifFalse: [(myStamps asOrderedCollection collect: [ :stamp | stamp orglRoot]) inspect]! printOn: aStream super printOn: aStream. (myEditions ~~ NULL and: [myEditions isEmpty not]) ifTrue: [aStream nextPut: $*].! ! !HBottomCrum methodsFor: 'smalltalk: gc'! {void} markChildren: count {IntegerVar} myTrace markInstances: count. myBertCrum markInstances: count.! ! !HBottomCrum methodsFor: 'smalltalk: passe'! {void} introduceStamp: stamp {BeEdition} self passe! {void} propChanged: change {PropChange} self passe! {void} removeStamp: stamp {BeEdition} self passe! ! !HBottomCrum methodsFor: 'deferred accessing'! {XnRegion} fetchRegionIn: stamp {BeEdition} with: hCut {TracePosition} with: region {XnRegion} Dean shouldImplement. "or else remove it again and get rid of polymorphs" ^NULL "fodder"! ! !HBottomCrum methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myTrace _ receiver receiveHeaper. myBertCrum _ receiver receiveHeaper. myEditions _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myTrace. xmtr sendHeaper: myBertCrum. xmtr sendHeaper: myEditions.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HBottomCrum class instanceVariableNames: ''! (HBottomCrum getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !HBottomCrum class methodsFor: 'instance creation'! {HBottomCrum} make [Ent] USES. ^self create: CurrentTrace fluidGet with: CurrentBertCrum fluidGet! !HistoryCrum subclass: #HUpperCrum instanceVariableNames: ' hcut {TracePosition} hcrums {MuSet of: OPart} myBertCrum {BertCrum}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Ents'! (HUpperCrum getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !HUpperCrum methodsFor: 'testing'! {BooleanVar} inTrace: trace {TracePosition} "Return true if the receiver can backfollow to trace." "This chase up the htree could terminate early if the trace equalled the trace in the receiver. This would be correct except that oplanes can be created with a particular trace, only part of which actually get included in the real orgl with that trace." (hcut isLE: trace) ifTrue: [hcrums stepper forEach: [:oc {OPart} | (oc hCrum inTrace: trace) ifTrue: [^true]]]. ^false! {BooleanVar} isEmpty "Return true if their are no upward pointers. This is used by OParts to determine if they can be forgotten." ^hcrums isEmpty! {Boolean} propagateBCrum: newBCrum {BertCrum} "If bertCrum is leafward of newBCrum then change it and return true, otherwise return false." (myBertCrum isLE: newBCrum) ifTrue: [^false] ifFalse: [[(newBCrum isLE: myBertCrum) assert: 'Unrelated bertsCrums!! Call dean.'] smalltalkOnly. myBertCrum _ newBCrum. ^true]! ! !HUpperCrum methodsFor: 'accessing'! {BertCrum} bertCrum "find the canopyCrum that goes with this hCrum." ^myBertCrum! {TracePosition} hCut ^hcut! {Mapping} mappingTo: trace {TracePosition} with: initial {Mapping} "return the mapping into the domain space of the given trace" | result {Mapping} | result _ Mapping make: initial coordinateSpace with: initial rangeSpace. (self inTrace: trace) ifTrue: [hcrums stepper forEach: [ :each {OPart} | result _ result combine: (each mappingTo: trace with: initial)]]. ^result! {ImmuSet of: OPart} oParents ^hcrums asImmuSet! ! !HUpperCrum methodsFor: 'updating'! {void} addOParent: newCrum {OPart} "If this hcrum represents a fork, then it must get its own canopy crum." "This routine could be drastically improved for orgl creation." self hack. [newCrum testHChild: self] smalltalkOnly. self updateBertCanopy: newCrum hCrum bertCrum. hcrums store: newCrum! {void} removeOParent: newCrum {OPart} "Make a history crum with no upward pointers." hcrums remove: newCrum.! ! !HUpperCrum methodsFor: 'filtering'! {void} actualDelayedStoreBackfollow: finder {PropFinder} with: fossil {RecorderFossil} with: recorder {ResultRecorder} with: hCrumCache {HashSetCache of: HistoryCrum} "Apply filter on canopy" | newFinder {PropFinder} | "Simplify finder (to cut out no longer reachable tests)." newFinder _ finder pass: myBertCrum. "If things are still findable, recur on each child." newFinder isEmpty ifFalse: [hcrums stepper forEach: [:loaf {OPart} | loaf hCrum delayedStoreBackfollow: newFinder with: fossil with: recorder with: hCrumCache]]! {BooleanVar} anyPasses: finder {PropFinder} (finder doesPass: myBertCrum) ifTrue: [hcrums stepper forEach: [:loaf {OPart} | (loaf hCrum anyPasses: finder) ifTrue: [^true]]]. ^false! {void} ringDetectors: edition {FeEdition} self bertCrum isSensorWaiting ifTrue: [self oParents stepper forEach: [ :o {OPart} | o hCrum ringDetectors: edition]]! ! !HUpperCrum methodsFor: 'private:'! {void} updateBertCanopy: bCrum {BertCrum} "Make my bertCrum the join of its current value and bCrum." (myBertCrum isLE: bCrum) ifFalse: [| oldBCrum {BertCrum} | oldBCrum _ myBertCrum. myBertCrum _ (myBertCrum computeJoin: bCrum) cast: BertCrum. (myBertCrum basicCast: BertCrum) ~~ (oldBCrum basicCast: BertCrum) ifTrue: [myBertCrum addPointer: self. oldBCrum removePointer: self]]! ! !HUpperCrum methodsFor: 'create'! create: trace {TracePosition} with: canopy {BertCrum} super create. hcut _ trace. myBertCrum _ canopy. myBertCrum addPointer: self. hcrums _ MuSet make! create: first {OPart} with: second {OPart} with: trace {TracePosition} | set {MuSet} | super create. hcut _ trace. "self halt." set _ MuSet make: 2. set introduce: first. set introduce: second. hcrums _ set. myBertCrum _ first hCrum bertCrum. self updateBertCanopy: second hCrum bertCrum. myBertCrum addPointer: self! ! !HUpperCrum methodsFor: 'smalltalk:'! inspectOrgls hcrums count == 1 ifTrue: [hcrums stepper get inspect] ifFalse: [hcrums asOrderedCollection inspect]! ! !HUpperCrum methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. hcut _ receiver receiveHeaper. hcrums _ receiver receiveHeaper. myBertCrum _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: hcut. xmtr sendHeaper: hcrums. xmtr sendHeaper: myBertCrum.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HUpperCrum class instanceVariableNames: ''! (HUpperCrum getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !HUpperCrum class methodsFor: 'smalltalk: create'! make: something {Heaper} (something isKindOf: HUpperCrum) ifTrue: [^self make.HUpperCrum: something]. (something isKindOf: BertCrum) ifTrue: [^self make.BertCrum: something]. Heaper BLAST: #FatalError! ! !HUpperCrum class methodsFor: 'instance creation'! make [Ent] USES. DiskManager consistent: [ ^HUpperCrum create: CurrentTrace fluidGet with: CurrentBertCrum fluidGet]. ^ NULL "Compiler fodder"! make.BertCrum: bertCrum {BertCrum} ^HUpperCrum create: CurrentTrace fluidGet with: bertCrum! make.HUpperCrum: hcrum {HUpperCrum} ^HUpperCrum create: hcrum hCut with: hcrum bertCrum! !Heaper subclass: #InstanceCache instanceVariableNames: ' myArray {PtrArray} myTop {Int32}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-cache'! InstanceCache comment: 'InstanceCache is intended to store a small number of frequently used objects with the intent of reducing memory allocation traffic.'! (InstanceCache getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; yourself)! !InstanceCache methodsFor: 'accessing'! {Heaper} fetch myTop >= Int32Zero ifTrue: [ | result {Heaper} | result := myArray fetch: myTop. myArray at: myTop store: NULL. myTop := myTop - 1. ^ result] ifFalse: [ ^ NULL]! {BooleanVar} store: object {Heaper} myTop < (myArray count - 1) ifTrue: [ myTop := myTop + 1. object destruct. (SuspendedHeaper new.Become: object) create. myArray at: myTop store: object. ^ true] ifFalse: [ ^ false]! ! !InstanceCache methodsFor: 'protected: create'! create: size {Int32} super create. myArray := PtrArray nulls: size. myTop := -1! ! !InstanceCache methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! InstanceCache class instanceVariableNames: ''! (InstanceCache getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; yourself)! !InstanceCache class methodsFor: 'create'! make: size {Int32} ^ self create: size! !Heaper subclass: #Joint instanceVariableNames: ' myUnioned {XnRegion} myIntersected {XnRegion}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-filter'! Joint comment: 'Joints are used to prune searches through trees of Regions. Each Joint summarizes the Joints and Regions at its node and its children using their intersection and union. If you maintain this information at each each node in the tree, then you can search for Regions in the tree efficiently using Filter::pass() to adapt the search criteria to the contents of the subtree. See also Filter::pass(Joint *).'! (Joint getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !Joint methodsFor: 'creation'! create: unioned {XnRegion} with: intersected{XnRegion} super create. myUnioned _ unioned. myIntersected _ intersected.! ! !Joint methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '(union: ' << myUnioned << '; intersected: ' << myIntersected << ')'! ! !Joint methodsFor: 'accessing'! {XnRegion INLINE} intersected "The intersection of the regions at all child nodes in the tree." ^myIntersected! {Joint INLINE} join: other {Joint} "A Joint that is a parent of this Joint and the given one." ^Joint make.Joint: self with: other! {XnRegion INLINE} unioned "The union of the regions at all child nodes in the tree." ^myUnioned! {Joint} with: region {XnRegion} "A Joint that is a parent of this one and the given region." ^Joint make.XnRegion: (myUnioned unionWith: region) with: (myIntersected intersect: region)! ! !Joint methodsFor: 'testing'! {UInt32} actualHashForEqual ^myUnioned hashForEqual + myIntersected hashForEqual! {BooleanVar} isEqual: other {Heaper} other cast: Joint into: [:o {Joint} | ^(myUnioned isEqual: o unioned) and: [myIntersected isEqual: o intersected]] others: [^false]. ^false "fodder"! ! !Joint methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myUnioned _ receiver receiveHeaper. myIntersected _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myUnioned. xmtr sendHeaper: myIntersected.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Joint class instanceVariableNames: ''! (Joint getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !Joint class methodsFor: 'pseudo constructors'! make.CoordinateSpace: space {CoordinateSpace} "An empty Joint in the given coordinate space." ^Joint create: space emptyRegion with: space fullRegion! make.Joint: left {Joint} with: right {Joint} "A joint that is a parent of the two given Joints." ^Joint create: (left unioned unionWith: right unioned) with: (left intersected intersect: right intersected)! make.ScruSet: subs {ScruSet of: Joint} "A Joint that is a parent of all of the Joints in the set." | unioned {XnRegion} intersected {XnRegion} subStepper {Stepper} | subStepper _ subs stepper. unioned _ (subStepper get cast: Joint) unioned. intersected _ (subStepper fetch cast: Joint) intersected. subStepper step. subStepper forEach: [ :sub {Joint} | unioned _ unioned unionWith: sub unioned. intersected _ intersected intersect: sub intersected]. ^Joint create: unioned with: intersected! make.XnRegion: both {XnRegion} "A Joint containing only the given region." ^Joint create: both with: both! make.XnRegion: unioned {XnRegion} with: intersected {XnRegion} "A Joint with the given union and intersection regions." ^Joint create: unioned with: intersected! ! !Joint class methodsFor: 'smalltalk: smalltalk defaults'! make: something (something isKindOf: XnRegion) ifTrue: [^self make.XnRegion: something]. (something isKindOf: CoordinateSpace) ifTrue: [^self make.CoordinateSpace: something]. ^self make.ScruSet: (something cast: ScruSet)! make: something with: other (something isKindOf: Joint) ifTrue: [^self make.Joint: something with: other]. ^self make.XnRegion: (something cast: XnRegion) with: other! !Emulsion subclass: #ListenerEmulsion instanceVariableNames: 'defaultFluidSpace {char star}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-srvloop'! !ListenerEmulsion methodsFor: 'accessing'! {void star} fetchNewRawSpace: size {#size.U.t var} (CurrentChunk == NULL) ifTrue: [ ["cxx: return (defaultFluidSpace = (char *) fcalloc (size, sizeof(char)));"] translateOnly. [^defaultFluidSpace _ Array new: size] smalltalkOnly] ifFalse: [ ["cxx: return CurrentChunk->fluidSpace( (char *) fcalloc (size, sizeof(char)) );"] translateOnly. [^CurrentChunk fluidSpace: (Array new: size)] smalltalkOnly]! {void star} fetchOldRawSpace (CurrentChunk == NULL) ifTrue: [ ^defaultFluidSpace. ] ifFalse: [ ^CurrentChunk fluidSpace.]! ! !ListenerEmulsion methodsFor: 'creation'! create super create. defaultFluidSpace _ NULL.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ListenerEmulsion class instanceVariableNames: ''! !ListenerEmulsion class methodsFor: 'smalltalk: passe'! make self passe. "use 'Listener listenerEmulsion'"! !Heaper subclass: #Lock instanceVariableNames: ' myLoginClubID {ID} myLockSmith {FeLockSmith}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Locks'! Lock comment: 'To login to a club, you ask the server for a Lock. If you send the right message to the Lock, it will return you a new KeyMaster with the authority of the club. Each subclass of Lock defines its own protocol for opening. For each kind of Lock, there is a corresponding kind of LockSmith which creates it. Each ClubManager has a LockSmith sub-document, and when you ask the server for a Lock to that club, it asks the club`s LockSmith document Wrapper to create a newLock. The LockSmith then creates the corresponding kind of Lock. It may also use information stored in the LockSmith document, such as a password or scramblerName.'! (Lock getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; add: #EQ; yourself)! !Lock methodsFor: 'create'! create: loginID {ID} with: lockSmith {FeLockSmith} super create. myLoginClubID := loginID. myLockSmith := lockSmith.! ! !Lock methodsFor: 'server accessing'! {FeKeyMaster} makeKeyMaster "The lock is opened - make the right KeyMaster" self hack. "This should eventually be done by manipulating the cookbooks" FeSession current isLoggedIn ifFalse: [FeSession current setInitialLogin: myLoginClubID]. ^FeKeyMaster make: myLoginClubID! ! !Lock methodsFor: 'protected:'! {ID} fetchLoginClubID "The ID of the club whose authority you can get by opening this lock." ^myLoginClubID! {FeLockSmith} lockSmith "Essential. The LockSmith which made this Lock." ^myLockSmith! ! !Lock methodsFor: 'smalltalk: passe'! {ID} loginClubID self passe "fetch"! ! !Lock methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! !Lock subclass: #BooLock instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Locks'! BooLock comment: 'A BooLock is very easy to open. Just say "boo". Since anyone can get in, only public clubs with little authority, such as System Public, should have BooLockSmiths.'! (BooLock getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !BooLock methodsFor: 'accessing'! {FeKeyMaster CLIENT login} boo "Essential. This is a very easy lock to open. Just say `boo'." ^self makeKeyMaster! ! !BooLock methodsFor: 'private: create'! create: clubID {ID} with: lockSmith {FeLockSmith} super create: clubID with: lockSmith! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BooLock class instanceVariableNames: ''! (BooLock getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !BooLock class methodsFor: 'pseudo constructors'! make: clubID {ID} with: lockSmith {FeLockSmith} ^self create: clubID with: lockSmith! ! !BooLock class methodsFor: 'smalltalk: system'! info.stProtocol "{FeKeyMaster CLIENT} boo "! !Lock subclass: #ChallengeLock instanceVariableNames: ' myChallenge {UInt8Array} myResponse {UInt8Array}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Locks'! ChallengeLock comment: 'A ChallengeLock challenges the client with a random piece of data that has been encrypted with a publicKey, using an algorithm identified by the encrypterName. The client must decrypt it using the corresponding private key and respond with the decrypted challenge. If it matches the original random data, then the lock will open. The encrypterName and the publicKey are stored in the club`s ChallengeLockSmith. '! (ChallengeLock getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !ChallengeLock methodsFor: 'private: create'! create: allegedID {ID} with: lockSmith {FeLockSmith} with: challenge {UInt8Array} with: response {UInt8Array} super create: allegedID with: lockSmith. myChallenge := challenge. myResponse := response.! ! !ChallengeLock methodsFor: 'accessing'! {UInt8Array CLIENT login} challenge "Essential. The challenge which must be signed correctly to open the lock." ^myChallenge copy cast: UInt8Array! {FeKeyMaster CLIENT login} response: signedChallenge {PrimIntArray} "Essential. The correctly signed challenge will open the lock." (self fetchLoginClubID ~~ NULL and: [myResponse contentsEqual: (signedChallenge cast: UInt8Array)]) ifFalse: [Heaper BLAST: #NotCorrectlySigned]. ^self makeKeyMaster! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ChallengeLock class instanceVariableNames: ''! (ChallengeLock getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !ChallengeLock class methodsFor: 'pseudo constructors'! make: loginID {ID | NULL} with: lockSmith {FeChallengeLockSmith} with: response {UInt8Array} ^self create: loginID with: lockSmith with: ((Encrypter make: (Sequence numbers: lockSmith encrypterName) with: lockSmith publicKey) encrypt: response) with: (response copy cast: UInt8Array)! ! !ChallengeLock class methodsFor: 'smalltalk: system'! info.stProtocol "{UInt8Array CLIENT} challenge {FeKeyMaster CLIENT} response: signedChallenge {UInt8Array} "! !Lock subclass: #MatchLock instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Locks'! MatchLock comment: 'The correct password will open the lock. The password is actually stored in the club`s MatchLockSmith in scrambled form, using a Scrambler identified by scramblerName(). The scrambled cleartext supplied as a password is compared to the scrambledPassword in the MatchLockSmith. If they match, the lock is opened. The actual process is a bit more complicated than this. The user supplies a password in clear, which is encrypted with the current system public key and then sent to the server. There, it is first decrypted with the private key known only to the server. It is then scrambled and compared with the scrambled password stored in the MatchLockSmith of the club. This procedure both avoids sending passwords in clear over the network, and also allows the MatchLockSmith to be made readable without compromising security.'! (MatchLock getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !MatchLock methodsFor: 'accessing'! {FeKeyMaster CLIENT login} encryptedPassword: encrypted {PrimIntArray} "Send the encrypted password to the server to be checked. NOTE: (for protocol review) The password must have been encrypted using a (yet-to-be-defined) front end library function, since this sort of front end computation can't be done with Promises." | cs {FeServer} | cs := CurrentServer fluidGet. (self fetchLoginClubID ~~ NULL and: [(self lockSmith cast: FeMatchLockSmith) scrambledPassword contentsEqual: (cs encrypter decrypt: (encrypted cast: UInt8Array))]) ifFalse: [Heaper BLAST: #DoesNotMatch]. ^self makeKeyMaster! ! !MatchLock methodsFor: 'private: create'! create: loginID {ID} with: lockSmith {FeMatchLockSmith} super create: loginID with: lockSmith! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MatchLock class instanceVariableNames: ''! (MatchLock getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !MatchLock class methodsFor: 'exceptions: exceptions'! problems.PasswordDoesNotMatch ^self signals: #(PasswordDoesNotMatch)! ! !MatchLock class methodsFor: 'pseudo constructors'! make: clubID {ID | NULL} with: lockSmith {FeMatchLockSmith} ^self create: clubID with: lockSmith! ! !MatchLock class methodsFor: 'smalltalk: system'! info.stProtocol "{FeKeyMaster CLIENT} encryptedPassword: encrypted {UInt8Array} "! !Lock subclass: #MultiLock instanceVariableNames: 'myLocks {ImmuTable of: Sequence and: Lock}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Locks'! MultiLock comment: 'A MultiLock allows the client to open the lock with any of a list of Locks. This allows a Club to have different passwords for different people; or, the Locks can use different kinds of native authentication systems such as NIS or Kerberos.'! (MultiLock getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !MultiLock methodsFor: 'create'! create: loginID {ID} with: lockSmith {FeMultiLockSmith} with: locks {ImmuTable of: Lock} super create: loginID with: lockSmith. myLocks := locks! ! !MultiLock methodsFor: 'accessing'! {Lock CLIENT login} lock: name {Sequence} "Get the named lock. You don't get any authority through a MultiLock directly, you merely get a Lock from which you can get authority." ^(myLocks get: name) cast: Lock! {SequenceRegion CLIENT login} lockNames "Essential. The names identifying the locks in the list" ^(self lockSmith cast: FeMultiLockSmith) lockSmithNames! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MultiLock class instanceVariableNames: ''! (MultiLock getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !MultiLock class methodsFor: 'create'! make: loginID {ID | NULL} with: lockSmith {FeMultiLockSmith} with: locks {ImmuTable of: Lock} ^self create: loginID with: lockSmith with: locks! ! !MultiLock class methodsFor: 'smalltalk: system'! info.stProtocol "{Lock CLIENT} lock: name {Sequence} {SequenceSpace CLIENT} lockNames "! !Lock subclass: #WallLock instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Locks'! WallLock comment: 'A Wall cannot be opened. Sorry, dude!!!! Clubs can have WallLockSmiths for a variety of reasons. Clubs that represent groups of users, and to which noone should be able to login directly (only as a member using loginToSuperClub), will have WallLockSmiths. Or, if you want to make a document read-only, remove all the members from its editClub, make it self-reading, and put a WallLockSmith on it; then, noone can login to the club, either directly or as a member, and noone can change it. '! (WallLock getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !WallLock methodsFor: 'private: create'! create: loginID {ID} with: lockSmith {FeLockSmith} super create: loginID with: lockSmith! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! WallLock class instanceVariableNames: ''! (WallLock getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #CONCRETE; yourself)! !WallLock class methodsFor: 'pseudo constructors'! make: clubID {ID | NULL} with: lockSmith {FeLockSmith} ^self create: clubID with: lockSmith! !Heaper subclass: #MainDummy instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-rcmain'! MainDummy comment: 'A dummy class on which to hang the main that reads in an rc file.'! (MainDummy getOrMakeCxxClassDescription) friends: '/* friends for class MainDummy */ friend int main (int argc, char* * argv);'; attributes: ((Set new) add: #DEFERRED; yourself)! !MainDummy methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MainDummy class instanceVariableNames: ''! (MainDummy getOrMakeCxxClassDescription) friends: '/* friends for class MainDummy */ friend int main (int argc, char* * argv);'; attributes: ((Set new) add: #DEFERRED; yourself)! !MainDummy class methodsFor: 'smalltalk: booting'! {void} run: filename self XU.U.MAIN: 2 with: (Array with: filename)! {void} runString: string Initializer doMain: [| rc {Rcvr} next {Heaper | NULL} | rc _ TextyXcvrMaker make makeRcvr: (TransferSpecialist make: (Cookbook make.String: 'boot')) with: (XnReadFile create: string readStream). next _ rc receiveHeaper. [next ~~ NULL] whileTrue: [next cast: Thunk into: [:thunk | thunk execute] others: []. next _ rc receiveHeaper]. rc destroy]. ^Int32Zero! {void} toFile: fileName {Filename} runString: string {String} | aStream saveCerr | aStream _ fileName writeStream. saveCerr _ cerr. [| rc {Rcvr} next {Heaper | NULL} | cerr _ aStream. self knownBug. "only accepts UInt8Arrays" rc _ TextyXcvrMaker make makeRcvr: (TransferSpecialist make: (Cookbook make.String: 'boot')) with: (XnReadFile create: string readStream). next _ rc receiveHeaper. [next ~~ NULL] whileTrue: [next cast: Thunk into: [:thunk | thunk execute] others: []. next _ rc receiveHeaper]. rc destroy] valueNowOrOnUnwindDo: [cerr _ saveCerr. aStream close]! ! !MainDummy class methodsFor: 'smalltalk: init'! staticTimeNonInherited Rcvr defineFluid: #CurrentMainReceiver with: Emulsion globalEmulsion with: [NULL]. Heaper defineFluid: #MainActiveThunk with: Emulsion globalEmulsion with: [NULL].! ! !MainDummy class methodsFor: 'global: booting'! {int} XU.U.MAIN: argc {int} with: argv {char star vector} | stackObject {Int32} | [StackExaminer] USES. 'StackExaminer::stackEnd(&stackObject);' translateOnly. Initializer with: argc with: argv doMain: [| rc {Rcvr} next {Heaper | NULL} | argc < 2 ifTrue: [cerr << 'usage: ' << (argv at: Int32Zero) << ' rcFileName '. ^1]. rc _ TextyXcvrMaker make makeRcvr: (TransferSpecialist make: (Cookbook make.String: 'boot')) with: (XnReadFile make: (argv at: 1)). CurrentMainReceiver fluidBind: rc during: [next _ CurrentMainReceiver fluidGet receiveHeaper. [next ~~ NULL] whileTrue: [MainActiveThunk fluidBind: next during: [next cast: Thunk into: [:thunk | thunk execute] others: []]. next _ CurrentMainReceiver fluidGet receiveHeaper]. CurrentMainReceiver fluidGet destroy]. ^Int32Zero]! ! !MainDummy class methodsFor: 'smalltalk: passe'! {int} main: argc {int} with: argv {char star vector} self passe! !Heaper subclass: #Mapping instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Spaces-Basic'! Mapping comment: 'A mapping is a general mapping from one coordinate space to another, with few of the guarantees provided by Dsps. In particular, the source and destination coordinate spaces can be different, and the mapping doesn''t have to be everywhere defined (but it has to say where it is defined via "domain" and "range" messages). A mapping doesn''t have to be unique--the same domain position may map to multiple range positions and vice versa. A mapping of a XuRegion must yield another XuRegion, but a mapping of a simple region doesn''t have to yield a simple region. A useful and valid way to think of a Mapping is as a (possibly infinite) set of pairs (a mathematical set, not a ScruSet). The domain region consists of the first elements of each pair, and the range region consists of the second elements. A mapping is most useful as a representation of a version comparison of two different organizations of common elements. The mapping would tell how positions in one organization correspond to positions in the other.'! (Mapping getOrMakeCxxClassDescription) friends: '/* friends for class Mapping */ friend void storeMapping (Mapping *, MuSet *); friend class SimpleMapping; '; attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; yourself)! !Mapping methodsFor: 'accessing'! {CoordinateSpace} coordinateSpace "the coordinate space of the domain of the Mapping" self subclassResponsibility! {XnRegion CLIENT} domain "Essential. region in which it is valid." self subclassResponsibility! {CoordinateSpace CLIENT INLINE} domainSpace "The coordinate space of the domain of the Mapping" ^self coordinateSpace! {Dsp | NULL} fetchDsp "if this is a Dsp or a Dsp retricted to some domain, return the underlying Dsp. Otherwise NULL." self subclassResponsibility! {BooleanVar CLIENT} isComplete "Essential. Return true if each Position in the domain is mapped to every Position in the range." Ravi thingToDo. "Decide what to do if it is not simple enough" self subclassResponsibility! {BooleanVar CLIENT} isIdentity "Essential. True if this is the identify mapping on the entire space." Ravi thingToDo. "Decide about domain" self subclassResponsibility! {XnRegion CLIENT} range "Essential. region in which inverse is valid. Same as the region that the domain region maps to. For you mathematicians, it is the image of the domain under the mapping." self subclassResponsibility! {CoordinateSpace CLIENT} rangeSpace "The coordinate space of the range of the transformation" self subclassResponsibility! {ImmuSet of: Mapping} simpleMappings "return a set of simple mappings that would combine to this one" self subclassResponsibility! {ImmuSet of: Mapping} simpleRegionMappings "return a set of mappings with simple regions as their domains that would combine to this one." self subclassResponsibility! {Stepper CLIENT of: Mapping} simplerMappings "Essential. Break this Mapping up into simpler Mappings which can be combined together to get this one." ^self simpleMappings stepper! {Mapping CLIENT} unrestricted "Essential. If this is a 'simpler' Mapping, and not isFull, then return a yet simpleMapping of some class from which you can get more information. Note that m->restrict (region)->unrestricted () is not necessarily the same as m, since information may be lost." self fetchDsp == NULL ifTrue: [Heaper BLAST: #NotSimpleEnough]. ^self fetchDsp! ! !Mapping methodsFor: 'mapping'! {Position} inverseOf: after {Position} "Inverse transform a position. Must BLAST if there isn't a unique inverse. 'a->isEqual (this->of (b))' iff 'b->isEqual (this->inverseOf (a))'." self subclassResponsibility! {XnRegion} inverseOfAll: after {XnRegion} "Inverse transform of a region. 'a->isEqual (this->of (b))' iff 'b->isEqual (this->inverseOf (a))'." self subclassResponsibility! {IntegerVar} inverseOfInt: pos {IntegerVar} "Unboxed version of 'this->inverseOf (xuInteger(pos))'. See discussion in the XuInteger class comment about boxed and unboxed protocols" ^((self inverseOf: pos integer) cast: IntegerPos) asIntegerVar! {Position CLIENT} of: before {Position} "Transform a position. 'before' must be a Position of my domain space. Iff 'before' is in the domain region over which I am defined and it maps to a unique range Position then the result will be that Position. Otherwise BLAST. For example, if I map 1 to 4, 1 to 5, and 2 to 5 (and nothing else), then this method will yield 5 given 2, but BLAST given anything else. To find all the values 1 maps to, use the 'ofAll' operation on the singleton region whose member is 1." self subclassResponsibility! {XnRegion CLIENT} ofAll: before {XnRegion} "Essential. Transform a region. The result region has exactly those positions which are the mappings of the positions in 'before'. This must be the case even if these positions cannot be enumerated. If the mapping for a given position is multiply defined, then (if that position is in 'before') all position it maps to must be in the result. Because of this property, the behavior of this method must be taken as really defining the nature of a particular mapping (with other method's behavior being defined in terms of this one), despite the fact that it would have been more natural to take Mapping::of(Position *) as the defining behavior." self subclassResponsibility! {IntegerVar} ofInt: pos {IntegerVar} "Unboxed version of 'this->of (xuInteger(pos))'. See discussion in the XuInteger class comment about boxed and unboxed protocols" ^ ((self of: pos integer) quickCast: IntegerPos) asIntegerVar! ! !Mapping methodsFor: 'operations'! {Mapping} appliedAfter: dsp {Dsp} "Defined by the equivalence: M->transformedBy(D)->of(R) isEqual (M->of(D->of(R))) for all regions R in the domainSpace of M. Equivalent to Dsp::compose, except that it is between a Mapping and a Dsp." self subclassResponsibility! {Mapping CLIENT} combine: other {Mapping} "Essential. Result will do both mine and other's mappings. It will do my mapping where I am defined, and it will do the other's where his is defined. If we are both defined over some domain positions, then the result is a multi-valued mapping. If you think of a Mapping simply as a set of pairs (see class comment), then 'combine' yields a Mapping consisting of the union of these two sets." | result {Mapping} | result _ self fetchCombine: other. result ~~ NULL ifTrue: [^result]. result _ other fetchCombine: self. result ~~ NULL ifTrue: [^result] ifFalse: [| set {MuSet of: Mapping} | set _ MuSet make. set store: self. set store: other. ^CompositeMapping privateMakeMapping: self domainSpace with: self rangeSpace with: set asImmuSet]! {Mapping CLIENT} inverse "Essential. Return the inverse of this transformation. Considering the Mapping as a set of pairs (see class comment), return the Dsp which has the mirror image of all my pairs." self subclassResponsibility! {Mapping} preCompose: dsp {Dsp} "There is no sensible explanation for what this message does on Mappings which aren't Dsps. In the future, we will probably retire this message, so don't use it." self subclassResponsibility! {Mapping CLIENT} restrict: region {XnRegion} "Essential. Restrict the domain. The domain of the result will be the intersection of my domain and 'region'. Otherwise we are the same." self subclassResponsibility! {Mapping} restrictRange: region {XnRegion} "Restrict the range. The range of the result will be the intersection of my range and 'region'. Otherwise we are the same." self subclassResponsibility! {Mapping} transformedBy: dsp {Dsp} "Defined by the equivalence: M->transformedBy(D)->of(R) isEqual (D->of(M->of(R))) for all regions R in the domainSpace of M. Equivalent to Dsp::preCompose, except that it is between a Mapping and a Dsp." self subclassResponsibility! ! !Mapping methodsFor: 'vulnerable: accessing'! {Mapping} fetchCombine: mapping {Mapping} "if I know how to combine the two into a single mapping, then I do so" self subclassResponsibility! ! !Mapping methodsFor: 'smalltalk: passe'! {PrimArray} export self passe! ! !Mapping methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Mapping class instanceVariableNames: ''! (Mapping getOrMakeCxxClassDescription) friends: '/* friends for class Mapping */ friend void storeMapping (Mapping *, MuSet *); friend class SimpleMapping; '; attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; yourself)! !Mapping class methodsFor: 'pseudo constructors'! {Mapping INLINE} make.CoordinateSpace: cs {CoordinateSpace} with.CoordinateSpace: rs {CoordinateSpace} "Make an empty mapping from cs to rs. The domain will consist of an empty region in cs, and the range will consist of an empty region in rs" ^EmptyMapping make: cs with: rs! make.CoordinateSpace: cs {CoordinateSpace} with.Region: values {XnRegion} "Make a constant mapping from all positions in cs to all positions in values." values isEmpty ifTrue: [^Mapping make.CoordinateSpace: cs with.CoordinateSpace: values coordinateSpace] ifFalse: [^ConstantMapping create: cs with: values]! {Mapping} make: cs {CoordinateSpace} with: rs {CoordinateSpace} with: mappings {ImmuSet of: Mapping} "The combine of all the mappings in 'mappings' All domains must be in cs and all ranges in rs. cs and rs must be provided in case 'mappings' is empty." mappings isEmpty ifTrue: [^EmptyMapping make: cs with: rs ] ifFalse: [| result {MuSet of: Mapping} | result _ MuSet make. mappings stepper forEach: [ :each {Mapping} | CompositeMapping storeMapping: each with: result]. ^CompositeMapping privateMakeMapping: cs with: rs with: mappings]! ! !Mapping class methodsFor: 'smalltalk: smalltalk defaults'! make: a with: b a cast: CoordinateSpace. (b isKindOf: CoordinateSpace) ifTrue: [^self make.CoordinateSpace: a with.CoordinateSpace: b]. ^self make.CoordinateSpace: a with.Region: (b cast: XnRegion)! ! !Mapping class methodsFor: 'smalltalk: passe'! make.Region: region {XnRegion} with: mapping {Mapping} self passe! ! !Mapping class methodsFor: 'smalltalk: system'! info.stProtocol "{Mapping CLIENT} combine: other {Mapping} {XuRegion CLIENT} domain {CoordinateSpace CLIENT} domainSpace {Mapping CLIENT} inverse {BooleanVar CLIENT} isComplete {BooleanVar CLIENT} isIdentity {Position CLIENT} of: before {Position} {XuRegion CLIENT} ofAll: before {XuRegion} {XuRegion CLIENT} range {CoordinateSpace CLIENT} rangeSpace {Mapping CLIENT} restrict: region {XuRegion} {Stepper CLIENT of: Mapping} simplerMappings {Mapping CLIENT} unrestricted "! !Mapping subclass: #CompositeMapping instanceVariableNames: ' myCS {CoordinateSpace} myRS {CoordinateSpace} myMappings {ImmuSet of: Mapping}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Spaces'! (CompositeMapping getOrMakeCxxClassDescription) friends: '/* friends for class CompositeMapping */ friend SPTR(Mapping) mapping(Mapping*, Mapping*); friend SPTR(Mapping) privateMakeMapping (CoordinateSpace *, CoordinateSpace *, ImmuSet OF1(Mapping) *);'; attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; add: #COPY; yourself)! !CompositeMapping methodsFor: 'operations'! {Mapping} appliedAfter: dsp {Dsp} | result {SetAccumulator of: Mapping} | result _ SetAccumulator make. myMappings stepper forEach: [ :each {Mapping} | result step: (each appliedAfter: dsp)]. ^CompositeMapping privateMakeMapping: self coordinateSpace with: self rangeSpace with: (result value cast: ImmuSet)! {Mapping} inverse | result {Mapping} | Ravi thingToDo. "can this be done more efficiently by taking advantage of invariants?" result := Mapping make.CoordinateSpace: self rangeSpace with: self domainSpace. myMappings stepper forEach: [ :sub {Mapping} | result := result combine: sub inverse]. ^result! {Mapping} preCompose: dsp {Dsp} | result {SetAccumulator of: Mapping} | result _ SetAccumulator make. myMappings stepper forEach: [ :each {Mapping} | result step: (each preCompose: dsp)]. ^CompositeMapping privateMakeMapping: self coordinateSpace with: self rangeSpace with: (result value cast: ImmuSet)! {Mapping} restrict: region {XnRegion} | result {MuSet of: Mapping} | result _ MuSet make. myMappings stepper forEach: [ :each {Mapping} | | restricted {Mapping} | restricted _ each restrict: region. restricted domain isEmpty ifFalse: [result store: restricted]]. ^CompositeMapping privateMakeMapping: self coordinateSpace with: self rangeSpace with: result asImmuSet! {Mapping} restrictRange: region {XnRegion} | result {MuSet of: Mapping} | result _ MuSet make. myMappings stepper forEach: [ :each {Mapping} | | restricted {Mapping} | restricted _ each restrictRange: region. restricted domain isEmpty ifFalse: [result store: restricted]]. ^CompositeMapping privateMakeMapping: self coordinateSpace with: self rangeSpace with: result asImmuSet! {Mapping} transformedBy: dsp {Dsp} | result {SetAccumulator of: Mapping} | result _ SetAccumulator make. myMappings stepper forEach: [ :each {Mapping} | result step: (each transformedBy: dsp)]. ^CompositeMapping privateMakeMapping: self coordinateSpace with: self rangeSpace with: (result value cast: ImmuSet)! ! !CompositeMapping methodsFor: 'accessing'! {CoordinateSpace} coordinateSpace ^myCS! {XnRegion} domain | result {XnRegion} | result _ self coordinateSpace emptyRegion. myMappings stepper forEach: [ :each {Mapping} | result _ result unionWith: each domain]. ^result! {Dsp | NULL} fetchDsp ^NULL! {BooleanVar} isComplete ^false "blast?"! {BooleanVar} isIdentity ^false! {XnRegion} range | result {XnRegion} | result _ self rangeSpace emptyRegion. myMappings stepper forEach: [ :each {Mapping} | result _ result unionWith: each range]. ^result! {CoordinateSpace} rangeSpace ^myRS! {ImmuSet of: Mapping} simpleMappings ^myMappings! {ImmuSet of: Mapping} simpleRegionMappings | simpleMappings {MuSet of: Mapping} eachSimple {Mapping} | simpleMappings _ MuSet make. myMappings stepper forEach: [ :each {Mapping} | each domain isSimple ifTrue: [simpleMappings store: each] ifFalse: [each domain simpleRegions forEach: [:simpleRegion {XnRegion} | eachSimple _ each restrict: simpleRegion. simpleMappings store: eachSimple]]]. ^(ImmuSet make.MuSet: simpleMappings)! ! !CompositeMapping methodsFor: 'transforming'! {Position} inverseOf: pos {Position} | result {Position} | result _ NULL. myMappings stepper forEach: [ :each {Mapping} | (each range hasMember: pos) ifTrue: [result == NULL ifTrue: [result _ each inverseOf: pos] ifFalse: [Heaper BLAST: #MultiplePreImages]]]. result == NULL ifTrue: [Heaper BLAST: #NotInRange]. ^result! {XnRegion} inverseOfAll: reg {XnRegion} | result {XnRegion} | result _ self coordinateSpace emptyRegion. myMappings stepper forEach: [ :each {Mapping} | result _ result unionWith: (each inverseOfAll: reg)]. ^result! {Position} of: pos {Position} | result {Position} | result _ NULL. myMappings stepper forEach: [ :each {Mapping} | (each domain hasMember: pos) ifTrue: [result == NULL ifTrue: [result _ each of: pos] ifFalse: [Heaper BLAST: #MultipleImages]]]. result == NULL ifTrue: [Heaper BLAST: #NotInDomain]. ^result! {XnRegion} ofAll: reg {XnRegion} | result {XnRegion} | result _ self rangeSpace emptyRegion. myMappings stepper forEach: [ :each {Mapping} | result _ result unionWith: (each ofAll: reg)]. ^result! ! !CompositeMapping methodsFor: 'printing'! {void} printOn: stream {ostream reference} stream << self getCategory name. myMappings printOnWithSimpleSyntax: stream with: '(' with: ', ' with: ')'! ! !CompositeMapping methodsFor: 'private: private creation'! create: cs {CoordinateSpace} with: rs {CoordinateSpace} with: mappings {ImmuSet of: Mapping} super create. myCS _ cs. myRS _ rs. myMappings _ mappings! ! !CompositeMapping methodsFor: 'testing'! {UInt32} actualHashForEqual ^#cat.U.CompositeMapping hashForEqual bitXor: myMappings hashForEqual! {BooleanVar} isEqual: other {Heaper} other cast: CompositeMapping into: [:cm | ^cm simpleMappings isEqual: myMappings] others: [^false]. ^false "fodder"! ! !CompositeMapping methodsFor: 'protected: protected'! {Mapping} fetchCombine: mapping {Mapping} (mapping isKindOf: EmptyMapping) ifTrue: [ ^ self ] ifFalse: [| result {MuSet of: Mapping} | result _ myMappings asMuSet. (mapping isKindOf: CompositeMapping) ifTrue: [mapping simpleMappings stepper forEach: [ :each {Mapping} | CompositeMapping storeMapping: each with: result]] ifFalse: [CompositeMapping storeMapping: mapping with: result]. ^CompositeMapping privateMakeMapping: myCS with: myRS with: result asImmuSet]! ! !CompositeMapping methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myCS _ receiver receiveHeaper. myRS _ receiver receiveHeaper. myMappings _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myCS. xmtr sendHeaper: myRS. xmtr sendHeaper: myMappings.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CompositeMapping class instanceVariableNames: ''! (CompositeMapping getOrMakeCxxClassDescription) friends: '/* friends for class CompositeMapping */ friend SPTR(Mapping) mapping(Mapping*, Mapping*); friend SPTR(Mapping) privateMakeMapping (CoordinateSpace *, CoordinateSpace *, ImmuSet OF1(Mapping) *);'; attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; add: #COPY; yourself)! !CompositeMapping class methodsFor: 'functions'! {Mapping} privateMakeMapping: cs {CoordinateSpace} with: rs {CoordinateSpace} with: mappings {ImmuSet of: Mapping} mappings isEmpty ifTrue: [^EmptyMapping make: cs with: rs] ifFalse: [mappings count = 1 ifTrue: [^mappings theOne cast: Mapping] ifFalse: [^CompositeMapping create: cs with: rs with: mappings]]! {void} storeMapping: map {Mapping} with: maps {MuSet of: Mapping} "store a map into the set, checking to see if it can be combined with another" maps stepper forEach: [ :each {Mapping} | | combined {Mapping} | combined _ map fetchCombine: each. combined ~~ NULL ifTrue: [combined _ each fetchCombine: map]. combined ~~ NULL ifTrue: [maps remove: each. maps introduce: combined. ^VOID]]. maps introduce: map! !Mapping subclass: #ConstantMapping instanceVariableNames: ' myCoordinateSpace {CoordinateSpace} myValues {XnRegion}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Spaces'! (ConstantMapping getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; add: #COPY; yourself)! !ConstantMapping methodsFor: 'creation'! create: cs {CoordinateSpace} with: values {XnRegion} super create. myCoordinateSpace _ cs. myValues _ values! ! !ConstantMapping methodsFor: 'transforming'! {Position} inverseOf: pos {Position unused} Heaper BLAST: #MultiplePreImages. ^NULL! {XnRegion} inverseOfAll: reg {XnRegion} (reg intersects: myValues) ifTrue: [^self domain] ifFalse: [^self coordinateSpace emptyRegion]! {Position} of: pos {Position unused} (myValues isFinite and: [myValues count == 1]) ifTrue: [^myValues theOne] ifFalse: [Heaper BLAST: #MultipleImages]. ^NULL "fodder"! {XnRegion} ofAll: reg {XnRegion} reg isEmpty ifTrue: [^self rangeSpace emptyRegion] ifFalse: [^self range]! ! !ConstantMapping methodsFor: 'accessing'! {Mapping} appliedAfter: dsp {Dsp unused} ^self! {CoordinateSpace} coordinateSpace ^ myCoordinateSpace! {XnRegion} domain ^myCoordinateSpace fullRegion! {Dsp | NULL} fetchDsp ^ NULL! {BooleanVar} isComplete ^true! {BooleanVar} isIdentity ^false! {Mapping} preCompose: dsp {Dsp} ^Mapping make.CoordinateSpace: myCoordinateSpace with.Region: (dsp ofAll: myValues)! {XnRegion} range ^myValues! {CoordinateSpace} rangeSpace ^myValues coordinateSpace! {ImmuSet of: Mapping} simpleMappings ^ ImmuSet make with: self.! {ImmuSet of: Mapping} simpleRegionMappings ^ ImmuSet make with: self.! {Mapping} transformedBy: dsp {Dsp} ^Mapping make.CoordinateSpace: myCoordinateSpace with.Region: (dsp ofAll: myValues)! ! !ConstantMapping methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '(' << myValues << ')'! ! !ConstantMapping methodsFor: 'testing'! {UInt32} actualHashForEqual ^myCoordinateSpace hashForEqual + myValues hashForEqual! {BooleanVar} isEqual: other {Heaper} other cast: ConstantMapping into: [:cm | ^(cm coordinateSpace isEqual: myCoordinateSpace) and: [cm values isEqual: myValues]] others: [^false]. ^false "fodder"! ! !ConstantMapping methodsFor: 'private: private'! {XnRegion} values ^myValues! ! !ConstantMapping methodsFor: 'operations'! {Mapping} inverse ^(Mapping make.CoordinateSpace: self rangeSpace with.Region: self domainSpace fullRegion) restrict: self range! {Mapping} restrict: region {XnRegion} ^SimpleMapping restrictTo: region with: self! {Mapping} restrictRange: region {XnRegion} ^Mapping make.CoordinateSpace: myCoordinateSpace with.Region: (myValues intersect: region)! ! !ConstantMapping methodsFor: 'protected'! {Mapping} fetchCombine: aMapping {Mapping} aMapping cast: ConstantMapping into: [:cm | ^Mapping make.CoordinateSpace: self coordinateSpace with.Region: (myValues unionWith: cm values)] others: [^NULL]. ^NULL "fodder"! ! !ConstantMapping methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myCoordinateSpace _ receiver receiveHeaper. myValues _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myCoordinateSpace. xmtr sendHeaper: myValues.! !Mapping subclass: #Dsp instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Spaces-Basic'! Dsp comment: 'A Dsp is a mapping from a coordinate space to itself that preserves simple regions. Every coordinate space must have an identity Dsp (which maps all positions of that space onto themselves). Dsps are necessarily invertable and composable. (Removed from CoordinateSpace because Dsps are still internal.: Dsp -- The transformations that can be applied to positions and regions of this cordinate space. A Dsp is necessarily invertible but generally not order-preserving. The composition of two Dsps is always a Dsp. If you can subtract two Dsps, the result will be another Dsp. The Dsp of a Position in this space is always another Position in this space. The Dsp of a simple region is always another simple region.) Considering a Mapping as a set of pairs, a Dsp is one for which each position appears exactly once in the first elements of the pairs, and exactly once in the second elements. Composition of Dsps isn''t necessarily commutative, though there are currently no counter-examples. Therefore we must be extra careful to avoid embodying commutativity assumptions in our code, as we currently have no way of finding such bugs.'! (Dsp getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !Dsp methodsFor: 'accessing'! {Mapping INLINE} appliedAfter: dsp {Dsp} "For Dsp's, it is identical to compose." ^self compose: dsp! {CoordinateSpace} coordinateSpace "the coordinate space of the domain and range of the Dsp" self subclassResponsibility! {XnRegion} domain "Must be valid everywhere in the domain for a Dsp." ^self coordinateSpace fullRegion! {(Dsp | NULL) INLINE} fetchDsp ^ self! {BooleanVar INLINE} isComplete ^false! {BooleanVar} isIdentity "Says whether this Dsp maps every Position onto itself" self subclassResponsibility! {Mapping} preCompose: dsp {Dsp} "a->compose(b) is the same as b->preCompose(a). Don't use it, use compose instead." ^dsp compose: self! {XnRegion} range ^self coordinateSpace fullRegion! {CoordinateSpace INLINE} rangeSpace "Same as the domain space" ^ self coordinateSpace! {ImmuSet of: Mapping} simpleMappings "A Dsp is a simpleMapping already, so this just returns the singleton set containing me" ^ ImmuSet make with: self.! {ImmuSet of: Mapping} simpleRegionMappings "The domain of a Dsp is the simple region covering the whole coordinate space, so I just return a singleton set containing myself" ^ ImmuSet make with: self.! {Mapping INLINE} transformedBy: dsp {Dsp} "For Dsp's, it is identical to preCompose." ^dsp compose: self! ! !Dsp methodsFor: 'combining'! {Dsp} compose: other {Dsp} "Return the composition of the two Dsps. Two Dsps of the same space are always composable. (a->compose(b) ->minus(b))->isEqual (a) (a->compose(b) ->of(pos))->isEqual (a->of (b->of (pos))" self subclassResponsibility! {Mapping} inverse "Return the inverse of this transformation. Considering the Dsp as a set of pairs (see class comment), return the Dsp which has the mirror image of all my pairs." self subclassResponsibility! {Dsp} minus: other {Dsp} "Return the difference of the two Dsps. (a->compose(b) ->minus(b))->isEqual (a)" self subclassResponsibility! ! !Dsp methodsFor: 'transforming'! {XnRegion} ofAll: reg {XnRegion} "If 'reg' is a simple region, then the result must also be simple" self subclassResponsibility! ! !Dsp methodsFor: 'operations'! {Mapping INLINE} restrict: region {XnRegion} ^SimpleMapping restrictTo: region with: self! {Mapping} restrictRange: region {XnRegion} ^SimpleMapping restrictTo: (self inverseOfAll: region) with: self! ! !Dsp methodsFor: 'protected:'! {Mapping} fetchCombine: mapping {Mapping} (self isEqual: mapping) ifTrue: [^self] ifFalse: [^NULL]! ! !Dsp methodsFor: 'deferred transforming'! {Position} inverseOf: pos {Position} "Since Dsps always represent a unique mapping in either direction, the permission to BLAST in the Mapping constract no longer applies. a->inverseOf(b) ->isEqual (a->inverse()->of(b))" ^(self inverse cast: Dsp) of: pos! {XnRegion} inverseOfAll: reg {XnRegion} "Inverse transform a region. A simple region must yield a simple region. a->inverseOfAll(b) ->isEqual (a->inverseAll()->of(b))" ^(self inverse cast: Dsp) ofAll: reg! {Position} of: pos {Position} "Since Dsps always represent a unique mapping in either direction, the permission to BLAST in the Mapping constract no longer applies." ^(self ofAll: pos asRegion) theOne! ! !Dsp methodsFor: 'deferred combining'! {Dsp} inverseCompose: other {Dsp} "Return the composition of my inverse with the other. a->inverseCompose(b) ->isEqual (a->inverse()->compose(b))" ^(self inverse cast: Dsp) compose: other! !Dsp subclass: #CrossMapping instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-cross'! CrossMapping comment: 'All other crossed mappings must be gotten by factoring the non-dsp aspects out into the generic non-dsp mapping objects. This class represents what remains after the factoring.'! (CrossMapping getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; yourself)! !CrossMapping methodsFor: 'transforming'! {XnRegion} ofAll: reg {XnRegion} self subclassResponsibility! ! !CrossMapping methodsFor: 'combining'! {Dsp} compose: other {Dsp} self subclassResponsibility! {Mapping} inverse self subclassResponsibility! {Dsp} minus: other {Dsp} self subclassResponsibility! ! !CrossMapping methodsFor: 'accessing'! {CoordinateSpace} coordinateSpace self subclassResponsibility! {BooleanVar} isIdentity self subclassResponsibility! {Dsp CLIENT} subMapping: index {Int32} "The Dsp applied to Positions in the given subspace." self subclassResponsibility! {PtrArray CLIENT of: Dsp} subMappings "The Mappings applied to Positions in each of the subspaces. Each of these is already simple enough that it is either the identityMapping or a visible subclass like IntegerMapping." self subclassResponsibility! ! !CrossMapping methodsFor: 'smalltalk: passe'! {Dsp} subDsp: index {Int32} self passe! {PtrArray of: Dsp} subDsps self passe "subMappings"! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CrossMapping class instanceVariableNames: ''! (CrossMapping getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; yourself)! !CrossMapping class methodsFor: 'pseudoconstructors'! make: space {CrossSpace} with: subDsps {(PtrArray of: Dsp | NULL) default: NULL} | subDs {PtrArray of: Dsp} | subDs := PtrArray nulls: space axisCount. Int32Zero almostTo: subDs count do: [:i {Int32} | subDs at: i store: (space axis: i) identityDsp]. subDsps ~~ NULL ifTrue: [Int32Zero almostTo: subDs count do: [:i {Int32} | | subDsp {Dsp | NULL} | (subDsp := (subDsps fetch: i) cast: Dsp) ~~ NULL ifTrue: [subDs at: i store: subDsp]]]. ^GenericCrossDsp create: space with: subDs! ! !CrossMapping class methodsFor: 'smalltalk: defaults'! make: space ^self make: space with: NULL! ! !CrossMapping class methodsFor: 'smalltalk: system'! info.stProtocol "{Dsp CLIENT} subMapping: index {Int32} {PtrArray CLIENT of: Dsp} subMappings "! !CrossMapping subclass: #GenericCrossDsp instanceVariableNames: ' mySpace {CrossSpace} mySubDsps {PtrArray of: Dsp}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-cross'! GenericCrossDsp comment: ' Was NOT.A.TYPE but that obstructed compilation.'! (GenericCrossDsp getOrMakeCxxClassDescription) friends: 'friend class GenericCrossSpace; '; attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !GenericCrossDsp methodsFor: 'accessing'! {CoordinateSpace} coordinateSpace ^mySpace! {BooleanVar} isIdentity Int32Zero almostTo: mySubDsps count do: [:i {Int32} | (self subMapping: i) isIdentity ifFalse: [^false]]. ^true! {Dsp} subMapping: index {Int32} ^(mySubDsps fetch: index) cast: Dsp! {PtrArray of: Dsp} subMappings ^mySubDsps copy cast: PtrArray! ! !GenericCrossDsp methodsFor: 'private: creation'! create: space {CrossSpace} with: subDsps {PtrArray of: Dsp} super create. mySpace := space. mySubDsps := subDsps! ! !GenericCrossDsp methodsFor: 'transforming'! {Position} inverseOf: position {Position} position cast: ActualTuple into: [ :tuple | | result {PtrArray of: Position} | result := PtrArray nulls: tuple count. Int32Zero almostTo: tuple count do: [ :dimension {Int32} | result at: dimension store: ((self subMapping: dimension) inverseOf: (tuple positionAt: dimension))]. ^ActualTuple make: result]. ^ NULL "compiler fodder"! {XnRegion} inverseOfAll: region {XnRegion} region cast: GenericCrossRegion into: [ :cross | | result {BoxAccumulator} boxes {BoxStepper} | result := BoxAccumulator make: mySpace with: cross boxCount. boxes := cross boxStepper. [boxes hasValue] whileTrue: [result addInverseTransformedBox: boxes with: self. boxes step]. ^result region]. ^ NULL "compiler fodder"! {Position} of: position {Position} position cast: ActualTuple into: [ :tuple | | result {PtrArray of: Position} | result := PtrArray nulls: tuple count. Int32Zero almostTo: tuple count do: [ :dimension {Int32} | result at: dimension store: ((self subMapping: dimension) of: (tuple positionAt: dimension))]. ^ActualTuple make: result]. ^ NULL "compiler fodder"! {XnRegion} ofAll: region {XnRegion} region cast: GenericCrossRegion into: [ :cross | | result {BoxAccumulator} boxes {BoxStepper} | result := BoxAccumulator make: mySpace with: cross boxCount. boxes := cross boxStepper. [boxes hasValue] whileTrue: [result addTransformedBox: boxes with: self. boxes step]. ^result region]. ^ NULL "compiler fodder"! ! !GenericCrossDsp methodsFor: 'combining'! {Dsp} compose: other {Dsp} | newSubDsps {PtrArray of: Dsp} | newSubDsps := PtrArray nulls: mySubDsps count. other cast: CrossMapping into: [ :cross | Int32Zero almostTo: newSubDsps count do: [ :dimension {Int32} | newSubDsps at: dimension store: ((self subMapping: dimension) compose: (cross subMapping: dimension))]. ^GenericCrossDsp make: mySpace with: newSubDsps]. ^ NULL "compiler fodder"! {Mapping} inverse | newSubDsps {PtrArray of: Dsp} | newSubDsps := PtrArray nulls: mySubDsps count. Int32Zero almostTo: newSubDsps count do: [ :dimension {Int32} | newSubDsps at: dimension store: ((self subMapping: dimension) inverse cast: Dsp)]. ^GenericCrossDsp create: mySpace with: newSubDsps! {Dsp} inverseCompose: other {Dsp} | newSubDsps {PtrArray of: Dsp} | newSubDsps := PtrArray nulls: mySubDsps count. other cast: CrossMapping into: [ :cross | Int32Zero almostTo: newSubDsps count do: [ :dimension {Int32} | newSubDsps at: dimension store: ((self subMapping: dimension) inverseCompose: (cross subMapping: dimension))]. ^GenericCrossDsp make: mySpace with: newSubDsps]. ^ NULL "compiler fodder"! {Dsp} minus: other {Dsp} | newSubDsps {PtrArray of: Dsp} | newSubDsps := PtrArray nulls: mySubDsps count. other cast: CrossMapping into: [ :cross | Int32Zero almostTo: newSubDsps count do: [ :dimension {Int32} | newSubDsps at: dimension store: ((self subMapping: dimension) minus: (cross subMapping: dimension))]. ^GenericCrossDsp make: mySpace with: newSubDsps]. ^ NULL "compiler fodder"! ! !GenericCrossDsp methodsFor: 'private: accessing'! {PtrArray of: Dsp} secretSubDsps "The actual array of sub Dsps. DO NOT MODIFY" ^mySubDsps! ! !GenericCrossDsp methodsFor: 'testing'! {UInt32} actualHashForEqual ^(mySpace hashForEqual bitXor: mySubDsps contentsHash) bitXor: self getCategory hashForEqual! {BooleanVar} isEqual: other {Heaper} other cast: GenericCrossDsp into: [ :cross | ^mySubDsps contentsEqual: cross secretSubDsps] others: [^false]. ^ false "compiler fodder"! ! !GenericCrossDsp methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. mySpace _ receiver receiveHeaper. mySubDsps _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: mySpace. xmtr sendHeaper: mySubDsps.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GenericCrossDsp class instanceVariableNames: ''! (GenericCrossDsp getOrMakeCxxClassDescription) friends: 'friend class GenericCrossSpace; '; attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !GenericCrossDsp class methodsFor: 'smalltalk: defaults'! make: space ^self make: space with: NULL! ! !GenericCrossDsp class methodsFor: 'private: pseudoconstructors'! {GenericCrossDsp} identity: space {GenericCrossSpace} with: subSpaces {PtrArray of: CoordinateSpace} "Only used during construction; must pass the array in explicitly since the space isnt initialized yet" | result {PtrArray of: Dsp} | result := PtrArray nulls: subSpaces count. Int32Zero almostTo: result count do: [ :dimension {Int32} | result at: dimension store: ((subSpaces fetch: dimension) cast: CoordinateSpace) identityDsp]. ^self create: space with: result! !Dsp subclass: #IdentityDsp instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Spaces-Unordered'! IdentityDsp comment: 'An implementation sharing convenience for Dsp classes which only provide the identity mapping functionality for their coordinate spaces. This provides everything except the coordinate space itself (which must be provided by the subclass). Will eventually be declared NOT_A_TYPE, so don''t use it in type declarations. Assumes that if a given space uses it as its identity Dsp, then the one cached instance will be the only identity Dsp for that space. I.e., I do equality comparison as an EQ object. If this assumpsion isn''t true, please override isEqual and hashForEqual. See PathDsp. IdentityDsp is in module "unorder" because typically unordered spaces will only have an identity Dsp and so want to subclass this class. Non-unordered spaces should also feel free to use this as appropriate.'! (IdentityDsp getOrMakeCxxClassDescription) friends: '/* friends for class IdentityDsp */ friend SPTR(Dsp) dsp(CoordinateSpace*); friend SPTR(Dsp) dsp(IntegerVar);'; attributes: ((Set new) add: #NOT.A.TYPE; add: #DEFERRED; yourself)! !IdentityDsp methodsFor: 'creation'! create super create! ! !IdentityDsp methodsFor: 'transforming'! {Position} inverseOf: pos {Position} ^pos! {XnRegion} inverseOfAll: reg {XnRegion} ^reg! {Position} of: pos {Position} ^pos! {XnRegion} ofAll: reg {XnRegion} ^reg! ! !IdentityDsp methodsFor: 'combining'! {Dsp} compose: other {Dsp} ^ other! {Mapping} inverse ^ self! {Dsp} inverseCompose: other {Dsp} ^ other! {Dsp} minus: other {Dsp} ^other inverse cast: Dsp! ! !IdentityDsp methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '(' << self coordinateSpace << ')'! ! !IdentityDsp methodsFor: 'accessing'! {BooleanVar} isIdentity ^ true! ! !IdentityDsp methodsFor: 'deferred accessing'! {CoordinateSpace} coordinateSpace self subclassResponsibility! ! !IdentityDsp methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! {BooleanVar} isEqual: other {Heaper} ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! IdentityDsp class instanceVariableNames: 'theDsp {IdentityDsp star} '! (IdentityDsp getOrMakeCxxClassDescription) friends: '/* friends for class IdentityDsp */ friend SPTR(Dsp) dsp(CoordinateSpace*); friend SPTR(Dsp) dsp(IntegerVar);'; attributes: ((Set new) add: #NOT.A.TYPE; add: #DEFERRED; yourself)! !IdentityDsp class methodsFor: 'smalltalk: smalltalk initialization'! initTimeInherited theDsp _ (self new.AllocType: #PERSISTENT) create.! linkTimeInherited theDsp _ NULL.! suppressInitTimeInherited! suppressLinkTimeInherited! !IdentityDsp subclass: #FilterDsp instanceVariableNames: 'myCS {FilterSpace}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Filter'! FilterDsp comment: 'There are no non-trivial Dsps currently defined on a FilterSpace. It would be possible to define them with reference to a Dsp in the baseSpace, as filterDsp->of(filter)->match(R) iff filter->match(filterDsp->baseDsp()->inverseOf(R)) for all R in the base space. However, we have not yet found a use for them.'! (FilterDsp getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !FilterDsp methodsFor: 'creation'! create: cs {CoordinateSpace} super create. myCS _ cs cast: FilterSpace.! ! !FilterDsp methodsFor: 'testing'! {UInt32} actualHashForEqual ^myCS hashForEqual + #cat.U.FilterDsp hashForEqual! {BooleanVar} isEqual: other {Heaper} other cast: FilterDsp into: [:fd | ^fd coordinateSpace isEqual: myCS] others: [^false]. ^false "fodder"! ! !FilterDsp methodsFor: 'accessing'! {CoordinateSpace} coordinateSpace ^myCS! ! !FilterDsp methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myCS _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myCS.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FilterDsp class instanceVariableNames: ''! (FilterDsp getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !FilterDsp class methodsFor: 'pseudo constructors'! make: cs {FilterSpace} "An identity Dsp on the given FilterSpace." ^FilterDsp create: cs! ! !FilterDsp class methodsFor: 'smalltalk: initialization'! suppressInitTimeInherited! suppressLinkTimeInherited! !IdentityDsp subclass: #HeaperDsp instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Spaces-Unordered'! (HeaperDsp getOrMakeCxxClassDescription) attributes: ((Set new) add: #PSEUDO.COPY; add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !HeaperDsp methodsFor: 'accessing'! {CoordinateSpace} coordinateSpace ^HeaperSpace make! ! !HeaperDsp methodsFor: 'creation'! create super create! ! !HeaperDsp methodsFor: 'generated:'! {void} sendSelfTo: xmtr {Xmtr}! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HeaperDsp class instanceVariableNames: ''! (HeaperDsp getOrMakeCxxClassDescription) attributes: ((Set new) add: #PSEUDO.COPY; add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !HeaperDsp class methodsFor: 'pseudo constructors'! {Dsp} make ^(theDsp basicCast: IdentityDsp) basicCast: HeaperDsp! {Heaper} make.Rcvr: rcvr {Rcvr} (rcvr cast: SpecialistRcvr) registerIbid: theDsp. ^theDsp! !IdentityDsp subclass: #IDDsp instanceVariableNames: 'mySpace {IDSpace}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Spaces-Unordered'! IDDsp comment: 'There are no non-trivial Dsps on IDs.'! (IDDsp getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #PSEUDO.COPY; yourself)! !IDDsp methodsFor: 'accessing'! {CoordinateSpace} coordinateSpace ^mySpace! ! !IDDsp methodsFor: 'creation'! create super create! create: space {IDSpace} super create. mySpace := space.! ! !IDDsp methodsFor: 'generated:'! {void} sendSelfTo: xmtr {Xmtr}! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! IDDsp class instanceVariableNames: ''! (IDDsp getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #PSEUDO.COPY; yourself)! !IDDsp class methodsFor: 'rcvr pseudo constructors'! {Heaper} make.Rcvr: rcvr {Rcvr} (rcvr cast: SpecialistRcvr) registerIbid: theDsp. ^theDsp! ! !IDDsp class methodsFor: 'pseudo constructors'! make: space {IDSpace} ^self create: space! ! !IDDsp class methodsFor: 'smalltalk: passe'! make self passe. ^theDsp cast: IDDsp! !IdentityDsp subclass: #RealDsp instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Filter'! (RealDsp getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !RealDsp methodsFor: 'deferred accessing'! {CoordinateSpace} coordinateSpace ^RealSpace make! ! !RealDsp methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RealDsp class instanceVariableNames: ''! (RealDsp getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !RealDsp class methodsFor: 'creation'! {Dsp} make ^self create! !Dsp subclass: #IntegerMapping instanceVariableNames: 'myTranslation {IntegerVar}' classVariableNames: 'TheIdentityIntegerMapping {IntegerMapping star} ' poolDictionaries: '' category: 'Xanadu-Spaces-Integers'! IntegerMapping comment: 'Transforms integers by adding a (possibly negative) offset. In addition to the Dsp protocol, an IntegerDsp will respond to "translation" with the offset that it is adding. Old documentation indicated a possibility of a future upgrade of IntegerDsp which would also optionally reflect (or negate) its input in addition to offsetting. This would however be a non-upwards compatable change in that current clients already assume that the answer to "translation" fully describes the IntegerDsp. If such a possibility is introduced, it should be as a super-type of IntegerDsp, since it would have a weaker contract. Then compatability problems can be caught by the type checker.'! (IntegerMapping getOrMakeCxxClassDescription) friends: '/* friends for class IntegerDsp */ friend class IntegerSpace; '; attributes: ((Set new) add: #PSEUDO.COPY; add: #CONCRETE; add: #ON.CLIENT; yourself)! !IntegerMapping methodsFor: 'unprotected for init creation'! create: translation {IntegerVar} "Initialize instance variables" super create. myTranslation _ translation.! ! !IntegerMapping methodsFor: 'printing'! {void} printOn: aStream {ostream reference} aStream << self getCategory name << '(' << myTranslation << ')'! ! !IntegerMapping methodsFor: 'transforming'! {Position} inverseOf: pos {Position} (pos ~~ NULL) assert. "shouldn't be necessary, but the old code used to check for NULL so I want to make sure I haven't broken anything" self == TheIdentityIntegerMapping ifTrue: [^pos] ifFalse: [^((pos cast: IntegerPos) asIntegerVar - myTranslation) integer]! {XnRegion} inverseOfAll: reg {XnRegion} | region {IntegerRegion} result {IntegerEdgeAccumulator} edges {IntegerEdgeStepper} resultReg {XnRegion} | self == TheIdentityIntegerMapping ifTrue: [^reg] ifFalse: [region _ reg cast: IntegerRegion. "Transform an interval by transforming the endpoints" result _ IntegerEdgeAccumulator make: region isBoundedBelow not with: region transitionCount. edges _ region edgeStepper. [edges hasValue] whileTrue: [result edge: (self inverseOfInt: edges edge). edges step]. edges destroy. resultReg _ result region. result destroy. ^ resultReg]! {IntegerVar} inverseOfInt: pos {IntegerVar} self == TheIdentityIntegerMapping ifTrue: [^pos]. ^pos - myTranslation! {Position} of: pos {Position} (pos ~~ NULL) assert. "shouldn't be necessary, but the old code used to check for NULL so I want to make sure I haven't broken anything" self == TheIdentityIntegerMapping ifTrue: [^pos] ifFalse: [^(myTranslation + (pos cast: IntegerPos) asIntegerVar) integer]! {XnRegion} ofAll: reg {XnRegion} | region {IntegerRegion} result {IntegerEdgeAccumulator} edges {IntegerEdgeStepper} resultReg {XnRegion} | self == TheIdentityIntegerMapping ifTrue: [^reg] ifFalse: [region _ reg cast: IntegerRegion. "Transform an interval by transforming the endpoints" result _ IntegerEdgeAccumulator make: region isBoundedBelow not with: region transitionCount. edges _ region edgeStepper. [edges hasValue] whileTrue: [result edge: (self ofInt: edges edge). edges step]. edges destroy. resultReg _ result region. result destroy. ^ resultReg]! {IntegerVar} ofInt: pos {IntegerVar} self == TheIdentityIntegerMapping ifTrue: [^pos]. ^ myTranslation + pos! ! !IntegerMapping methodsFor: 'accessing'! {CoordinateSpace INLINE} coordinateSpace ^ IntegerSpace make! {BooleanVar INLINE} isIdentity ^ myTranslation = IntegerVar0! {IntegerVar CLIENT INLINE} translation "The offset which I add to a position. If my translation is 7, then this->of(4) is 11." ^myTranslation! ! !IntegerMapping methodsFor: 'testing'! {UInt32} actualHashForEqual ^ (myTranslation) DOTasLong + #cat.U.IntegerMapping hashForEqual! {BooleanVar} isEqual: other {Heaper} "Should have same offset and reversal" other cast: IntegerMapping into: [:iDsp | ^iDsp translation = myTranslation] others: [^false]. ^ false "compiler fodder"! ! !IntegerMapping methodsFor: 'combining'! {Dsp} compose: other {Dsp} self == TheIdentityIntegerMapping ifTrue: [^ other] ifFalse: [other == TheIdentityIntegerMapping ifTrue: [^ self]]. ^IntegerMapping make: (myTranslation + (other quickCast: IntegerMapping) translation)! {Mapping} inverse self == TheIdentityIntegerMapping ifTrue: [^self]. ^IntegerMapping make: myTranslation negated! {Dsp} inverseCompose: other {Dsp} self == TheIdentityIntegerMapping ifTrue: [ ^ other ] ifFalse: [ ^ other minus: self ]! {Dsp} minus: other {Dsp} other == TheIdentityIntegerMapping ifTrue: [ ^self ] ifFalse: [ ^IntegerMapping make: (myTranslation - (other cast: IntegerMapping) translation)]! ! !IntegerMapping methodsFor: 'sender'! {void SEND.HOOK} sendIntegerMapping: xmtr {Xmtr} xmtr sendIntegerVar: myTranslation.! ! !IntegerMapping methodsFor: 'generated:'! {void} sendSelfTo: xmtr {Xmtr} self sendIntegerMapping: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! IntegerMapping class instanceVariableNames: ''! (IntegerMapping getOrMakeCxxClassDescription) friends: '/* friends for class IntegerDsp */ friend class IntegerSpace; '; attributes: ((Set new) add: #PSEUDO.COPY; add: #CONCRETE; add: #ON.CLIENT; yourself)! !IntegerMapping class methodsFor: 'smalltalk: init'! initTimeNonInherited TheIdentityIntegerMapping _ (IntegerMapping new.AllocType: #PERSISTENT) create: IntegerVar0! linkTimeNonInherited TheIdentityIntegerMapping _ NULL! ! !IntegerMapping class methodsFor: 'pseudo constructors'! make ^IntegerSpace make identityDsp cast: IntegerMapping! {Heaper} make.Rcvr: rcvr {Rcvr} | translate {IntegerVar} result {Heaper} | translate _ rcvr receiveIntegerVar. translate == IntegerVarZero ifTrue: [result _ TheIdentityIntegerMapping] ifFalse: [result _ self create: translate]. (rcvr cast: SpecialistRcvr) registerIbid: result. ^result! make: translate {IntegerVar} translate == IntegerVar0 ifTrue: [^self make] ifFalse: [^self create: translate]! ! !IntegerMapping class methodsFor: 'private: for create'! {Dsp} identity ^self create: IntegerVarZero! ! !IntegerMapping class methodsFor: 'smalltalk: system'! info.stProtocol "{IntegerVar CLIENT} translation "! !Dsp subclass: #SequenceMapping instanceVariableNames: ' myShift {IntegerVar} myTranslation {Sequence}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-tumbler'! SequenceMapping comment: 'Transforms a Sequence by shifting some amount, and then adding another Sequence to it.'! (SequenceMapping getOrMakeCxxClassDescription) friends: '/* friends for class SequenceDsp */ friend class SequenceSpace; '; attributes: ((Set new) add: #CONCRETE; add: #ON.CLIENT; add: #COPY; yourself)! !SequenceMapping methodsFor: 'accessing'! {CoordinateSpace INLINE} coordinateSpace ^SequenceSpace make! {BooleanVar} isIdentity ^myShift == IntegerVarZero and: [myTranslation isZero]! {IntegerVar CLIENT INLINE} shift "The amount by which it shifts a sequence" ^myShift! {Sequence CLIENT INLINE} translation "What it adds to a sequence after shifting it" ^myTranslation! ! !SequenceMapping methodsFor: 'transforming'! {Position} inverseOf: position {Position} position cast: Sequence into: [ :sequence | ^(sequence minus: myTranslation) shift: myShift negated]. ^ NULL "compiler fodder"! {XnRegion} inverseOfAll: reg {XnRegion} Ravi thingToDo. "make this more efficient" ^self inverse ofAll: reg! {Position} of: position {Position} position cast: Sequence into: [ :sequence | ^(sequence shift: myShift) plus: myTranslation]. ^ NULL "compiler fodder"! {XnRegion} ofAll: reg {XnRegion} reg cast: SequenceRegion into: [ :seq | | edges {PtrArray of: SequenceEdge} newEdges {PtrArray of: SequenceEdge} | edges := seq secretTransitions. newEdges := PtrArray nulls: edges count. Int32Zero almostTo: edges count do: [ :i {Int32} | newEdges at: i store: (((edges fetch: i) cast: SequenceEdge) transformedBy: self)]. ^SequenceRegion usingx: seq startsInside with: newEdges]. ^NULL "fodder"! ! !SequenceMapping methodsFor: 'combining'! {Dsp} compose: dsp {Dsp} "Return the composition of the two Dsps. Two Dsps of the same space are always composable. (a->compose(b) ->minus(b))->isEqual (a) (a->compose(b) ->of(pos))->isEqual (a->of (b->of (pos))" dsp cast: SequenceMapping into: [ :other {SequenceMapping} | ^SequenceMapping make: myShift + other shift with: ((self of: other translation) cast: Sequence)]. ^ NULL "compiler fodder"! {Mapping} inverse ^SequenceMapping make: myShift negated with: ((Sequence zero minus: myTranslation) shift: myShift)! {Dsp} inverseCompose: dsp {Dsp} dsp cast: SequenceMapping into: [ :other | ^SequenceMapping make: myShift - other shift with: ((self inverseOf: other translation) cast: Sequence)]. ^ NULL "compiler fodder"! {Dsp} minus: dsp {Dsp} dsp cast: SequenceMapping into: [ :other | ^SequenceMapping make: myShift - other shift with: ((self inverseOf: other translation) cast: Sequence)]. ^ NULL "compiler fodder"! ! !SequenceMapping methodsFor: 'private: create'! create: shift {IntegerVar} with: translation {Sequence} super create. myShift := shift. myTranslation := translation.! ! !SequenceMapping methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myShift _ receiver receiveIntegerVar. myTranslation _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendIntegerVar: myShift. xmtr sendHeaper: myTranslation.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! SequenceMapping class instanceVariableNames: ''! (SequenceMapping getOrMakeCxxClassDescription) friends: '/* friends for class SequenceDsp */ friend class SequenceSpace; '; attributes: ((Set new) add: #CONCRETE; add: #ON.CLIENT; add: #COPY; yourself)! !SequenceMapping class methodsFor: 'private: pseudo constructors'! make: shift {IntegerVar} with: translation {Sequence} ^self create: shift with: translation! ! !SequenceMapping class methodsFor: 'smalltalk: system'! info.stProtocol "{IntegerVar CLIENT} shift {Sequence CLIENT} translation "! !Mapping subclass: #EmptyMapping instanceVariableNames: ' myCS {CoordinateSpace} myRS {CoordinateSpace}' classVariableNames: ' LastEmptyMapping {Mapping} LastEmptyMappingCoordinateSpace {CoordinateSpace} LastEmptyMappingRangeSpace {CoordinateSpace} ' poolDictionaries: '' category: 'Xanadu-Spaces'! (EmptyMapping getOrMakeCxxClassDescription) friends: '/* friends for class EmptyMapping */ friend SPTR(Mapping) emptyMapping (CoordinateSpace * cs, CoordinateSpace * rs); '; attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; add: #COPY; yourself)! !EmptyMapping methodsFor: 'accessing'! {CoordinateSpace} coordinateSpace ^myCS! {XnRegion} domain ^ self coordinateSpace emptyRegion.! {Dsp | NULL} fetchDsp ^NULL! {BooleanVar} isComplete ^true! {BooleanVar} isIdentity ^false! {XnRegion} range ^ self rangeSpace emptyRegion.! {CoordinateSpace} rangeSpace ^myRS! {ImmuSet of: Mapping} simpleMappings ^ ImmuSet make! {ImmuSet of: Mapping} simpleRegionMappings ^ ImmuSet make with: self.! ! !EmptyMapping methodsFor: 'transforming'! {Position} inverseOf: pos {Position unused} Heaper BLAST: #NotInRange. ^ NULL! {XnRegion} inverseOfAll: reg {XnRegion unused} ^ self coordinateSpace emptyRegion.! {Position} of: pos {Position unused} Heaper BLAST: #NotInDomain. ^ NULL! {XnRegion} ofAll: reg {XnRegion unused} ^self rangeSpace emptyRegion.! ! !EmptyMapping methodsFor: 'private: private creation'! create: cs {CoordinateSpace} with: rs {CoordinateSpace} super create. myCS _ cs. myRS _ rs.! ! !EmptyMapping methodsFor: 'printing'! {void} printOn: stream {ostream reference} stream << self getCategory name. stream << '()'! ! !EmptyMapping methodsFor: 'testing'! {UInt32} actualHashForEqual ^#cat.U.EmptyMapping hashForEqual! {BooleanVar} isEqual: other {Heaper} "This, and the CompositeMapping version, don't check CoordinateSpaces. Should they?" ^(other isKindOf: EmptyMapping)! ! !EmptyMapping methodsFor: 'operations'! {Mapping} appliedAfter: dsp {Dsp unused} ^self! {Mapping} inverse ^Mapping make.CoordinateSpace: self rangeSpace with.CoordinateSpace: self domainSpace! {Mapping} preCompose: dsp {Dsp unused} ^ self! {Mapping} restrict: region {XnRegion unused} ^self! {Mapping} restrictRange: region {XnRegion unused} ^self! {Mapping} transformedBy: dsp {Dsp unused} ^ self! ! !EmptyMapping methodsFor: 'protected: protected'! {Mapping} fetchCombine: mapping {Mapping} ^ mapping! ! !EmptyMapping methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myCS _ receiver receiveHeaper. myRS _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myCS. xmtr sendHeaper: myRS.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! EmptyMapping class instanceVariableNames: ''! (EmptyMapping getOrMakeCxxClassDescription) friends: '/* friends for class EmptyMapping */ friend SPTR(Mapping) emptyMapping (CoordinateSpace * cs, CoordinateSpace * rs); '; attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; add: #COPY; yourself)! !EmptyMapping class methodsFor: 'smalltalk: initialization'! linkTimeNonInherited LastEmptyMapping _ NULL. LastEmptyMappingCoordinateSpace _ NULL. LastEmptyMappingRangeSpace _ NULL.! ! !EmptyMapping class methodsFor: 'pseudoconstructor'! {Mapping} make: cs {CoordinateSpace} with: rs {CoordinateSpace} (LastEmptyMapping == NULL or: [(cs isEqual: LastEmptyMappingCoordinateSpace) not or: [(rs isEqual: LastEmptyMappingRangeSpace) not]]) ifTrue: [LastEmptyMappingCoordinateSpace _ cs. LastEmptyMappingRangeSpace _ rs. LastEmptyMapping _ EmptyMapping create: cs with: rs]. ^ LastEmptyMapping! !Mapping subclass: #SimpleMapping instanceVariableNames: ' myRegion {XnRegion} myMapping {Mapping}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Spaces-Basic'! (SimpleMapping getOrMakeCxxClassDescription) friends: '/* friends for class SimpleMapping */ friend SPTR(Mapping) restrictTo (XnRegion*, Mapping*); '; attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !SimpleMapping methodsFor: 'accessing'! {Mapping} appliedAfter: dsp {Dsp} ^SimpleMapping restrictTo: (dsp inverseOfAll: myRegion) with: (myMapping appliedAfter: dsp)! {CoordinateSpace} coordinateSpace ^myRegion coordinateSpace! {XnRegion} domain ^ myRegion! {Dsp | NULL} fetchDsp ^ myMapping fetchDsp! {BooleanVar} isComplete ^myMapping isComplete! {BooleanVar} isIdentity ^false! {Mapping} preCompose: dsp {Dsp} ^SimpleMapping restrictTo: myRegion with: (myMapping preCompose: dsp)! {XnRegion} range ^ myMapping ofAll: myRegion! {CoordinateSpace} rangeSpace ^ myMapping rangeSpace! {ImmuSet of: Mapping} simpleMappings ^ ImmuSet make with: self! {ImmuSet of: Mapping} simpleRegionMappings myMapping domain isSimple ifTrue: [^ImmuSet make with: myMapping] ifFalse: [ | simpleMappings {MuSet} | simpleMappings _ MuSet make. myMapping domain simpleRegions forEach: [:simpleRegion {XnRegion} | simpleMappings store: (myMapping restrict: simpleRegion)]. ^ImmuSet make.MuSet: simpleMappings]! {Mapping} transformedBy: dsp {Dsp} ^SimpleMapping restrictTo: myRegion with: (myMapping transformedBy: dsp)! ! !SimpleMapping methodsFor: 'transforming'! {Position} inverseOf: pos {Position} | result {Position} | result _ myMapping inverseOf: pos. (myRegion hasMember: result) ifTrue: [^result] ifFalse: [Heaper BLAST: #NotInRange]. ^NULL "fodder"! {XnRegion} inverseOfAll: reg {XnRegion} ^(myMapping inverseOfAll: reg) intersect: myRegion! {Position} of: pos {Position} (self domain hasMember: pos) ifTrue: [^ myMapping of: pos] ifFalse: [Heaper BLAST: #NotInDomain]. ^NULL "fodder"! {XnRegion} ofAll: reg {XnRegion} ^myMapping ofAll: (self domain intersect: reg)! ! !SimpleMapping methodsFor: 'operations'! {Mapping} inverse ^myMapping inverse restrictRange: myRegion! {Mapping} restrict: region {XnRegion} ^SimpleMapping restrictTo: (myRegion intersect: region) with: myMapping! {Mapping} restrictRange: region {XnRegion} ^SimpleMapping restrictTo: myRegion with: (myMapping restrictRange: region)! ! !SimpleMapping methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << myMapping << ' on ' << myRegion! ! !SimpleMapping methodsFor: 'private: private creation'! create: region {XnRegion} with: mapping {Mapping} super create. myRegion _ region. myMapping _ mapping.! ! !SimpleMapping methodsFor: 'testing'! {UInt32} actualHashForEqual ^myRegion hashForEqual + myMapping hashForEqual! {BooleanVar} isEqual: other {Heaper} other cast: SimpleMapping into: [:sm | ^(sm domain isEqual: myRegion) and: [sm mapping isEqual: myMapping]] others: [^false]. ^false "fodder"! ! !SimpleMapping methodsFor: 'private: private'! {Mapping} mapping ^myMapping! ! !SimpleMapping methodsFor: 'protected'! {Mapping} fetchCombine: mapping {Mapping} (mapping isEqual: myMapping) ifTrue: [^mapping]. mapping cast: SimpleMapping into: [:other | | both {Mapping} | (other mapping isEqual: myMapping) ifTrue: [^SimpleMapping restrictTo: (other domain unionWith: myRegion) with: myMapping] ifFalse: [((other domain isEqual: myRegion) and: [(both _ myMapping fetchCombine: other mapping) ~~ NULL]) ifTrue: [^SimpleMapping restrictTo: myRegion with: both]]] others: []. ^NULL! ! !SimpleMapping methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myRegion _ receiver receiveHeaper. myMapping _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myRegion. xmtr sendHeaper: myMapping.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! SimpleMapping class instanceVariableNames: ''! (SimpleMapping getOrMakeCxxClassDescription) friends: '/* friends for class SimpleMapping */ friend SPTR(Mapping) restrictTo (XnRegion*, Mapping*); '; attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !SimpleMapping class methodsFor: 'pseudo constructors'! {Mapping} restrictTo: region {XnRegion} with: mapping {Mapping} region isEmpty ifTrue: [^EmptyMapping make: mapping domainSpace with: mapping rangeSpace] ifFalse: [^SimpleMapping create: region with: mapping]! !Heaper subclass: #OrderSpec instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Spaces-Basic'! OrderSpec comment: '[documentation note: we need to hide the documentation about partial orders, but still warn that the orders may become partial]. An OrderSpec for a given coordinate space represents a partial ordering of all the Positions of that coordinate space. The fundamental ordering relationship is "follows". The response of Positions to isGE defines the natural, "ascending" partial order among the positions. Every coordinate space will have at least this ascending and the corresponding descending OrderSpecs. OrderSpecs are useful to specify in what order a stepper produced for stepping over positions should do so.'! (OrderSpec getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; add: #COPY; yourself)! !OrderSpec methodsFor: 'smalltalk: defaults'! isFullOrder ^self isFullOrder: NULL! ! !OrderSpec methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! {OrderEnum} compare: x {Position} with: y {Position} "Say what the relative ordering relationship is between x and y" (self follows: x with: y) ifTrue: [(self follows: y with: x) ifTrue: [^#EQUAL] ifFalse: [^#GREATER.U.THAN]] ifFalse: [(self follows: y with: x) ifTrue: [^#LESS.U.THAN] ifFalse: [^#INCOMPARABLE]]! {BooleanVar CLIENT} follows: x {Position} with: y {Position} "Essential. Compare the two and return true if x is known to follow y in the ordering. This message is the 'greater than or equal to' equivalent for this ordering. It must have those properties a mathematician would demand of a '>=' on a partial order: os->follows(a, a) (reflexivity) os->follows(a, b) && os->follows(b, c) implies os->follows(a, c) (transitivity) os->follows(a, b) && os->follows(b, a) implies a->isEqual(b) (what's the name for this?)" self subclassResponsibility! {BooleanVar} followsInt: x {IntegerVar} with: y {IntegerVar} "See discussion in XuInteger class comment about boxed vs unboxed integers" ^self follows: x integer with: y integer! {BooleanVar} isEqual: other {Heaper} self subclassResponsibility! {BooleanVar} isFullOrder: keys {XnRegion default: NULL} "Essential. If this returns TRUE, then I define a full order over all positions in 'keys' (or all positions in the space if 'keys' is NULL). However, if I return FALSE, that doesn't guarantee that I don't define a full ordering. I may happen to define a full ordering without knowing it. A full ordering is one in which for each a, b in keys; either this->follows(a, b) or this->follows(b, a)." self subclassResponsibility! {BooleanVar} preceeds: before {XnRegion} with: after {XnRegion} "Return true if some position in before is less than or equal to all positions in after." self subclassResponsibility! ! !OrderSpec methodsFor: 'accessing'! {Arrangement} arrange: region {XnRegion} "Return an Arrangement of the positions in region according to the ordering of the receiver." ^ExplicitArrangement make: ((region stepper: self) stepMany cast: PtrArray)! {CoordinateSpace CLIENT} coordinateSpace "Essential. Like Positions, Dsps, and XuRegions, an OrderSpec is specific to one coordinate space. It is an error to use the generic protocol on objects from different coordinate spaces." self subclassResponsibility! {OrderSpec CLIENT} reversed "Returns an OrderSpec representing the mirror image of my ordering. o->follows(a, b) iff o->reverse()->follows(b, a)" ^ReverseOrder make: self! ! !OrderSpec methodsFor: 'smalltalk: passe'! {PrimArray} export self passe! ! !OrderSpec methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! OrderSpec class instanceVariableNames: ''! (OrderSpec getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; add: #COPY; yourself)! !OrderSpec class methodsFor: 'smalltalk: passe'! {OrderSpec} ascending: cs {CoordinateSpace} "Use CoordinateSpace::fetch/getAscending" self passe! {OrderSpec} descending: cs {CoordinateSpace} "Use CoordinateSpace::fetch/getDescending" self passe! ! !OrderSpec class methodsFor: 'smalltalk: system'! info.stProtocol "{CoordinateSpace CLIENT} coordinateSpace {BooleanVar CLIENT} follows: x {Position} with: y {Position} {OrderSpec CLIENT} reversed "! !OrderSpec subclass: #CrossOrderSpec instanceVariableNames: ' mySpace {CrossSpace} mySubOrders {PtrArray of: OrderSpec} myLexOrder {PrimIntArray}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-cross'! CrossOrderSpec comment: 'myLexOrder lists the lexicographic order in which each dimension should be processed. Every dimension should be listed exactly one, from most significant (at index 0) to least significant. mySubOrders are indexed by *dimension*, not by lexicographic order. In order to index by lex order, look up the dimension in myLexOrder, and then look up the resulting dimension number in mySubOrders.'! (CrossOrderSpec getOrMakeCxxClassDescription) friends: 'friend class GenericCrossSpace; '; attributes: ((Set new) add: #CONCRETE; add: #ON.CLIENT; add: #COPY; yourself)! !CrossOrderSpec methodsFor: 'private: creation'! create: space {CrossSpace} with: subOrders {PtrArray of: OrderSpec} with: lexOrder {PrimIntArray} super create. mySpace := space. mySubOrders := subOrders. myLexOrder := lexOrder! ! !CrossOrderSpec methodsFor: 'accessing'! {CoordinateSpace INLINE} coordinateSpace ^mySpace! {PrimIntArray CLIENT} lexOrder "Lists the lexicographic order in which each dimension should be processed. Every dimension is listed exactly once, from most significant (at index 0) to least significant." ^myLexOrder copy cast: PrimIntArray! {OrderSpec CLIENT} subOrder: i {Int32} "The sub OrderSpec used for the given axis. Note that this is *not* in lex order." ^(mySubOrders fetch: i) cast: OrderSpec! {PtrArray CLIENT of: OrderSpec} subOrders "The sub OrderSpec used for each axis in the space. Note that this is *not* in lex order, but rather indexed by axis number." ^mySubOrders copy cast: PtrArray! ! !CrossOrderSpec methodsFor: 'testing'! {UInt32} actualHashForEqual ^mySpace hashForEqual bitXor: (mySubOrders hashForEqual bitXor: myLexOrder hashForEqual ).! {BooleanVar} follows: x {Position unused} with: y {Position unused} MarkM shouldImplement. ^false "fodder"! {BooleanVar} isEqual: other {Heaper unused} Someone shouldImplement. ^false "fodder"! {BooleanVar} isFullOrder: keys {XnRegion unused default: NULL} "Essential. If this returns TRUE, then I define a full order over all positions in 'keys' (or all positions in the space if 'keys' is NULL). However, if I return FALSE, that doesn't guarantee that I don't define a full ordering. I may happen to define a full ordering without knowing it. A full ordering is one in which for each a, b in keys; either this->follows(a, b) or this->follows(b, a)." ^false. "any 2 d or greater space has no fullordering" "Someone shouldImplement." "fodder"! {BooleanVar} preceeds: before {XnRegion} with: after {XnRegion} "Return true if some position in before is less than or equal to all positions in after." before cast: GenericCrossRegion into: [ :bc | after cast: GenericCrossRegion into: [ :ac | Int32Zero almostTo: myLexOrder count do: [ :i {Int32} | | dim {Int32} sub {OrderSpec} | dim := (myLexOrder integerAt: i) DOTasLong. sub := (mySubOrders get: dim) cast: OrderSpec. Int32Zero almostTo: bc boxCount do: [ :bi {Int32} | | bp {XnRegion} | bp := bc boxProjection: bi with: dim. Int32Zero almostTo: ac boxCount do: [ :ai {Int32} | | ap {XnRegion} | ap := ac boxProjection: ai with: dim. (sub preceeds: bp with: ap) ifTrue: [^true]]]]. ^false] others: [self unimplemented]] others: [self unimplemented]. ^false "fodder"! ! !CrossOrderSpec methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. mySpace _ receiver receiveHeaper. mySubOrders _ receiver receiveHeaper. myLexOrder _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: mySpace. xmtr sendHeaper: mySubOrders. xmtr sendHeaper: myLexOrder.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CrossOrderSpec class instanceVariableNames: ''! (CrossOrderSpec getOrMakeCxxClassDescription) friends: 'friend class GenericCrossSpace; '; attributes: ((Set new) add: #CONCRETE; add: #ON.CLIENT; add: #COPY; yourself)! !CrossOrderSpec class methodsFor: 'pseudoconstructors'! make: space {CrossSpace} with: subOrderings {(PtrArray of: OrderSpec | NULL) default: NULL} with: lexOrder {PrimIntArray default: NULL} | lexO {PrimIntArray} subOrders {PtrArray of: OrderSpec} | subOrders := PtrArray nulls: space axisCount. Int32Zero almostTo: subOrders count do: [:i {Int32} | subOrders at: i store: (space axis: i) fetchAscending]. subOrderings ~~ NULL ifTrue: [Int32Zero almostTo: subOrders count do: [:i {Int32} | | subOrder {OrderSpec | NULL} | subOrder := (subOrderings fetch: i) cast: OrderSpec. subOrder == NULL ifTrue: [(subOrders fetch: i) ~~ NULL assert: 'Must have an ordering from each space'] ifFalse: [subOrders at: i store: subOrder]]]. lexOrder == NULL ifTrue: [lexO := PrimIntArray zeros: 32 with: subOrders count. Int32Zero almostTo: subOrders count do: [:i {Int32} | lexO at: i storeInteger: i]] ifFalse: [lexO := lexOrder]. ^self create: space with: subOrders with: lexO! ! !CrossOrderSpec class methodsFor: 'smalltalk: defaults'! make: space ^self make space with: NULL with: NULL! make: space with: subOrderings ^self make space with: subOrderings with: NULL! ! !CrossOrderSpec class methodsFor: 'private: pseudo constructors'! {CrossOrderSpec} fetchAscending: space {GenericCrossSpace} with: subSpaces {PtrArray of: CoordinateSpace} "Only used during construction; must pass the array in explicitly since the space isnt initialized yet" | result {PtrArray of: OrderSpec} lex {PrimIntArray} | result := PtrArray nulls: subSpaces count. lex := PrimIntArray zeros: 32 with: subSpaces count. Int32Zero almostTo: result count do: [ :dimension {Int32} | | sub {OrderSpec} | sub := ((subSpaces fetch: dimension) cast: CoordinateSpace) fetchAscending. sub == NULL ifTrue: [^NULL]. result at: dimension store: sub. lex at: dimension storeInteger: dimension]. ^self create: space with: result with: lex! {CrossOrderSpec} fetchDescending: space {GenericCrossSpace} with: subSpaces {PtrArray of: CoordinateSpace} "Only used during construction; must pass the array in explicitly since the space isnt initialized yet" | result {PtrArray of: OrderSpec} lex {PrimIntArray} | result := PtrArray nulls: subSpaces count. lex := PrimIntArray zeros: 32 with: subSpaces count. Int32Zero almostTo: result count do: [ :dimension {Int32} | | sub {OrderSpec} | sub := ((subSpaces fetch: dimension) cast: CoordinateSpace) fetchAscending. sub == NULL ifTrue: [^NULL]. result at: dimension store: sub. lex at: dimension storeInteger: dimension]. ^self create: space with: result with: lex! ! !CrossOrderSpec class methodsFor: 'smalltalk: system'! info.stProtocol "{Int32Array CLIENT} lexOrder {OrderSpec CLIENT} subOrder: i {Int32} {PtrArray CLIENT of: OrderSpec} subOrders "! !OrderSpec subclass: #IDUpOrder instanceVariableNames: 'myIDSpace {IDSpace}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-tumbler'! (IDUpOrder getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !IDUpOrder methodsFor: 'testing'! {UInt32} actualHashForEqual ^self getCategory hashForEqual! {BooleanVar} follows: x {Position} with: y {Position} x cast: ID into: [ :a | y cast: ID into: [ :b | Ravi thingToDo. "more efficient comparison" ^(b backend isGE: a backend) not or: [(a backend isEqual: b backend) and: [a number >= b number]]]]. ^false "fodder"! {BooleanVar} isEqual: other {Heaper} ^other isKindOf: IDUpOrder! {BooleanVar} isFullOrder: keys {XnRegion default: NULL} ^true! {BooleanVar} preceeds: before {XnRegion} with: after {XnRegion} "Return true if some position in before is less than or equal to all positions in after." | beforeB {SequenceRegion} afterB {SequenceRegion} bound {Sequence} | before cast: IDRegion into: [ :beforeIDs | after cast: IDRegion into: [ :afterIDs | beforeB := beforeIDs backends. afterB := afterIDs backends. (SequenceSpace make ascending preceeds: beforeB with: afterB) ifFalse: [^false]. beforeB isBoundedBelow ifFalse: [^true]. bound := beforeB lowerBound. (bound isEqual: afterB lowerBound) ifFalse: [^true]. ^IntegerSpace make ascending preceeds: (beforeIDs iDNumbersFrom: bound) with: (afterIDs iDNumbersFrom: bound)]]. ^false "fodder"! ! !IDUpOrder methodsFor: 'accessing'! {Arrangement} arrange: region {XnRegion} | stepper {Stepper} array {PtrArray} | region isFinite ifFalse: [Heaper BLAST: #MustBeFinite]. stepper := (region cast: IDRegion) stepper. array := stepper stepMany cast: PtrArray. stepper atEnd ifFalse: [self unimplemented]. ^ExplicitArrangement make: array! {CoordinateSpace} coordinateSpace ^myIDSpace! ! !IDUpOrder methodsFor: 'create'! create: space {IDSpace} super create. myIDSpace := space.! ! !IDUpOrder methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myIDSpace _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myIDSpace.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! IDUpOrder class instanceVariableNames: ''! (IDUpOrder getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !IDUpOrder class methodsFor: 'pseudo constructors'! {OrderSpec} make: space {IDSpace} ^self create: space.! !OrderSpec subclass: #IntegerUpOrder instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Spaces-Basic'! (IntegerUpOrder getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !IntegerUpOrder methodsFor: 'testing'! {UInt32} actualHashForEqual ^#cat.U.IntegerUpOrder hashForEqual + 1! {BooleanVar} follows: x {Position} with: y {Position} ^(x cast: IntegerPos) asIntegerVar >= (y cast: IntegerPos) asIntegerVar! {BooleanVar} followsInt: x {IntegerVar} with: y {IntegerVar} "See discussion in XuInteger class comment about boxed vs unboxed integers" ^ x >= y! {BooleanVar} isEqual: other {Heaper} ^other isKindOf: IntegerUpOrder! {BooleanVar} isFullOrder: keys {XnRegion unused default: NULL} ^true! {BooleanVar} preceeds: before {XnRegion} with: after {XnRegion} "Return true if some position in before is less than or equal to all positions in after." | first {IntegerRegion} second {IntegerRegion} | first _ before cast: IntegerRegion. second _ after cast: IntegerRegion. first isBoundedBelow ifFalse: [^true]. second isBoundedBelow ifFalse: [^false]. ^first start <= second start! ! !IntegerUpOrder methodsFor: 'accessing'! {Arrangement} arrange: region {XnRegion} ^IntegerArrangement make: region with: self.! {XnRegion} chooseMany: region {XnRegion} with: n {IntegerVar} "Return the first n positions in the region according to my ordering." ^(self arrange: region) keysOf: Int32Zero with: n DOTasLong! {Position} chooseOne: region {XnRegion} "Return the first position in the region according to my ordering." ^IntegerPos make: (region cast: IntegerRegion) start! {CoordinateSpace} coordinateSpace ^IntegerSpace make! ! !IntegerUpOrder methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! IntegerUpOrder class instanceVariableNames: ''! (IntegerUpOrder getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !IntegerUpOrder class methodsFor: 'pseudoconstructors'! {OrderSpec} make ^self create! !OrderSpec subclass: #RealUpOrder instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-tumbler'! (RealUpOrder getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !RealUpOrder methodsFor: 'accessing'! {Arrangement} arrange: region {XnRegion} | stepper {Stepper} array {PtrArray} | region isFinite ifFalse: [Heaper BLAST: #MustBeFinite]. stepper := (region cast: RealRegion) stepper. array := stepper stepMany cast: PtrArray. stepper atEnd ifFalse: [self unimplemented]. ^ExplicitArrangement make: array! {CoordinateSpace} coordinateSpace ^RealSpace make! ! !RealUpOrder methodsFor: 'testing'! {UInt32} actualHashForEqual ^#cat.U.RealUpOrder hashForEqual + 1! {BooleanVar} follows: x {Position} with: y {Position} MarkM thingToDo. "128 bit values" ^(x cast: RealPos) asIEEE64 >= (y cast: RealPos) asIEEE64! {BooleanVar} isEqual: other {Heaper} ^other isKindOf: RealUpOrder! {BooleanVar} isFullOrder: keys {XnRegion default: NULL} ^true! {BooleanVar} preceeds: before {XnRegion} with: after {XnRegion} before cast: RealRegion into: [ :br | br isBoundedBelow ifFalse: [^true]. after cast: RealRegion into: [ :ar | ^ar isBoundedBelow not and: [self follows: ar lowerBound with: br lowerBound]]]. ^false "fodder"! ! !RealUpOrder methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RealUpOrder class instanceVariableNames: ''! (RealUpOrder getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !RealUpOrder class methodsFor: 'creation'! {OrderSpec} make ^self create! !OrderSpec subclass: #ReverseOrder instanceVariableNames: 'myOrder {OrderSpec}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Spaces-Basic'! (ReverseOrder getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !ReverseOrder methodsFor: 'accessing'! {CoordinateSpace} coordinateSpace ^myOrder coordinateSpace! {OrderSpec} reversed ^myOrder! ! !ReverseOrder methodsFor: 'testing'! {UInt32} actualHashForEqual ^myOrder hashForEqual bitXor: -1! {BooleanVar} follows: x {Position} with: y {Position} ^myOrder follows: y with: x! {BooleanVar} followsInt: x {IntegerVar} with: y {IntegerVar} ^myOrder followsInt: y with: x! {BooleanVar} isEqual: other{Heaper} other cast: OrderSpec into: [:os | ^myOrder isEqual: os reversed] others: [^false]. ^false "fodder"! {BooleanVar} isFullOrder: keys {XnRegion default: NULL} ^myOrder isFullOrder: keys! {BooleanVar} preceeds: before {XnRegion} with: after {XnRegion} "Return true if some position in before is less than or equal to all positions in after." self unimplemented. ^false! ! !ReverseOrder methodsFor: 'private: creation'! create: order {OrderSpec} super create. myOrder := order! ! !ReverseOrder methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myOrder _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myOrder.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ReverseOrder class instanceVariableNames: ''! (ReverseOrder getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !ReverseOrder class methodsFor: 'pseudoconstructors'! {OrderSpec} make: order {OrderSpec} ^self create: order! !OrderSpec subclass: #SequenceUpOrder instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-tumbler'! (SequenceUpOrder getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !SequenceUpOrder methodsFor: 'testing'! {UInt32} actualHashForEqual ^self getCategory hashForEqual! {BooleanVar} follows: x {Position} with: y {Position} ^((x cast: Sequence) secretNumbers compare: (y cast: Sequence) secretNumbers) >= Int32Zero! {BooleanVar} isEqual: other {Heaper} ^other isKindOf: SequenceUpOrder! {BooleanVar} isFullOrder: keys {XnRegion unused default: NULL} ^true! {BooleanVar} preceeds: before {XnRegion} with: after {XnRegion} | first {SequenceRegion} second {SequenceRegion} | first _ before cast: SequenceRegion. second _ after cast: SequenceRegion. first isBoundedBelow ifFalse: [^true]. second isBoundedBelow ifFalse: [^false]. ^(((first secretTransitions fetch: Int32Zero) cast: SequenceEdge) isGE: ((second secretTransitions fetch: Int32Zero) cast: SequenceEdge)) not! ! !SequenceUpOrder methodsFor: 'accessing'! {Arrangement} arrange: region {XnRegion} | stepper {Stepper} array {PtrArray} | region isFinite ifFalse: [Heaper BLAST: #MustBeFinite]. stepper := (region cast: SequenceRegion) stepper. array := stepper stepMany cast: PtrArray. stepper atEnd ifFalse: [self unimplemented]. ^ExplicitArrangement make: array! {CoordinateSpace} coordinateSpace ^SequenceSpace make! ! !SequenceUpOrder methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! SequenceUpOrder class instanceVariableNames: ''! (SequenceUpOrder getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !SequenceUpOrder class methodsFor: 'pseudo constructors'! {OrderSpec} make ^self create! !Heaper subclass: #Pair instanceVariableNames: ' leftPart {Heaper copy} rightPart {Heaper copy}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Tables'! Pair comment: 'Sometimes you just want to pass around two things where the language only makes it convenient to pass around one. I know that the proper object-oriented (or even "structured") thing to do would be to create a type specific to the particular kind of pair which is being used for a particular purpose. However, sometimes it just seems like too much trouble. By using Pairs, we import the sins of Lisp. At least we don''t have RPLACA and RPLACD. Unlike Lisp''s cons cell''s "car" and "cdr", we call our two parts the "left" part and the "right" part. "pair(a,b)->left()" yields a and "pair(a,b)->right()" yields b. Give us feedback: Should Pairs be removed? Do you know of any justification for them other than a bad simulation of "multiple-return-values" (as in Common Lisp, Forth, Postscript)? The Pair code is currently in a state of transition. Old code (which we have yet to fix) uses Pairs with NULLs in their parts. Pairs will be changed to outlaw this usage. "fetchLeft" and "fetchRight" exist to support this obsolete usage, but will be retired. Don''t use them.'! (Pair getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !Pair methodsFor: 'testing'! {UInt32} actualHashForEqual | result {UInt32} | leftPart ~~ NULL ifTrue: [result _ leftPart hashForEqual] ifFalse: [result _ 37]. rightPart ~~ NULL ifTrue: [^ result + rightPart hashForEqual] ifFalse: [^ result + 73]! {BooleanVar} isEqual: other {Heaper} | res {BooleanVar} | other cast: Pair into: [:pair | leftPart == NULL ifTrue: [res _ pair fetchLeft == NULL] ifFalse: [res _ leftPart isEqual: pair left]. res ifTrue: [rightPart == NULL ifTrue: [^pair fetchRight == NULL] ifFalse: [^rightPart isEqual: pair right]] ifFalse: [^false]] others: [^false]. ^ false "compiler fodder"! ! !Pair methodsFor: 'accessing'! {Heaper} left "Returns the left part. Lispers may think 'car'." leftPart == NULL ifTrue: [Heaper BLAST: #ObsoleteUsageMustUseFetchLeft]. ^leftPart! {Pair INLINE} reversed "Returns a new pair which is the left-right reversal of me. pair(a,b)->reversed() is the same as pair(b,a). Only works on non-obsolete Pairs--those whose parts are non-NULL" ^Pair make: rightPart with: leftPart! {Heaper} right "Returns the right part. Lispers may think 'cdr'." rightPart == NULL ifTrue: [Heaper BLAST: #ObsoleteUsageMustUseFetchRight]. ^rightPart! ! !Pair methodsFor: 'instance creation'! create: a {Heaper} with: b {Heaper} "create a new pair" super create. leftPart _ a. rightPart _ b.! ! !Pair methodsFor: 'smalltalk:'! inspectPieces "Return pieces to be used in a tree browser." ^OrderedCollection with: leftPart with: rightPart! ! !Pair methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << '<' << leftPart << ' , ' << rightPart << '>'! ! !Pair methodsFor: 'obsolete: access'! {Heaper INLINE | NULL} fetchLeft "Returns the left part which obsoletely may be NULL" ^leftPart! {Heaper INLINE | NULL} fetchRight "Returns the right part which obsoletely may be NULL" ^rightPart! ! !Pair methodsFor: 'smalltalk: passe'! create: a {Heaper} "create a new pair" self passe! ! !Pair methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. leftPart _ receiver receiveHeaper. rightPart _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: leftPart. xmtr sendHeaper: rightPart.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Pair class instanceVariableNames: ''! (Pair getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !Pair class methodsFor: 'instance creation'! make: left {Heaper} with: right {Heaper} "Create a new pair. Since it used to be normal to allow either left or right to be NULL (it is now obsolete but supported for the moment), and it is impossible to do a static check, this (normal) pseudo-constructor does a dynamic check. If you encounter this error, the quick fix is use the obsolete pseudo-constructor (pairWithNulls). The better fix is to stop using NULLs." (left == NULL or: [right = NULL]) ifTrue: [Heaper BLAST: #ObsoleteUsageMustUsePairWithNulls]. ^self create: left with: right! ! !Pair class methodsFor: 'obsolete: creation'! {Pair} pairWithNulls: left {Heaper} with: right {Heaper} "Create a new pair. Either may be NULL in order to support broken old code." ^self create: left with: right! !Heaper subclass: #Portal instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! (Portal getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #EQ; yourself)! !Portal methodsFor: 'accessing'! {XnReadStream} readStream self subclassResponsibility! {XnWriteStream} writeStream self subclassResponsibility! ! !Portal methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Portal class instanceVariableNames: ''! (Portal getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #EQ; yourself)! !Portal class methodsFor: 'pseudo constructors'! make: host {char star} with: port {UInt32} ^SocketPortal make: host with: port! !Portal subclass: #PacketPortal instanceVariableNames: ' myReadStream {XnReadStream} myWriteStream {XnWriteStream}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! (PacketPortal getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !PacketPortal methodsFor: 'protected: creation'! create super create. myReadStream _ XnBufferedReadStream create: self. myWriteStream _ XnBufferedWriteStream create: self.! create: readStr {XnReadStream} with: writeStr {XnWriteStream} super create. myReadStream _ readStr. myWriteStream _ writeStr! ! !PacketPortal methodsFor: 'accessing'! {XnReadStream} readStream ^myReadStream! {XnWriteStream} writeStream ^myWriteStream! ! !PacketPortal methodsFor: 'internal'! {void} flush "Make sure the bits go out." self subclassResponsibility! {UInt8Array} readBuffer "Return a buffer of a size that the unerlying transport layer likes." self subclassResponsibility! {Int32} readPacket: buffer {UInt8Array} with: count {Int32} self subclassResponsibility! {UInt8Array} writeBuffer "Return a buffer of a size that the unerlying transport layer likes." self subclassResponsibility! {void} writePacket: packet {UInt8Array} with: count {Int32} self subclassResponsibility! !Portal subclass: #PairPortal instanceVariableNames: ' myReadStream {XnReadStream} myWriteStream {XnWriteStream}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! (PairPortal getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !PairPortal methodsFor: 'accessing'! {XnReadStream} readStream ^myReadStream! {XnWriteStream} writeStream ^myWriteStream! ! !PairPortal methodsFor: 'protected: creation'! create: readStr {XnReadStream} with: writeStr {XnWriteStream} super create. myReadStream _ readStr. myWriteStream _ writeStr! {void} destruct myReadStream destroy. myWriteStream destroy. super destruct! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PairPortal class instanceVariableNames: ''! (PairPortal getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !PairPortal class methodsFor: 'creation'! make: read {XnReadStream} with: write {XnWriteStream} ^self create: read with: write! !Heaper subclass: #Position instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Spaces-Basic'! Position comment: 'This is the superclass of all positions of coordinate spaces. Each individual position is specific to some one coordinate space. Positions themselves don''t have much behavior, as most of the interesting aspects of coordinate spaces are defined in the other objects in terms of positions. Positions do have their own native ordering messages, but for most purposes it''s probably better to compare them using an appropriate OrderSpec.'! (Position getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; yourself)! !Position methodsFor: 'testing'! {UInt32} actualHashForEqual "since we redefine equal, subclasses had better redefine actualHashForEqual" ^Heaper takeOop! {BooleanVar} isEqual: other {Heaper} self subclassResponsibility! ! !Position methodsFor: 'accessing'! {XnRegion CLIENT} asRegion "Essential. A region containing this position as its only element." self subclassResponsibility! {CoordinateSpace CLIENT} coordinateSpace "Essential. The coordinate space this is a position in. This implies that a position object is only a position in one particular coordinate space." self subclassResponsibility! ! !Position methodsFor: 'smalltalk: passe'! {BooleanVar} isAfterOrEqual: other {Position} "OBSOLETE. Use OrderSpec instead, or non-polymorphic subclass methods. This must define a full ordering on all positions in the same coordinate space. As this isn''t possible for some coordinate spaces (e.g. HeaperSpace & FilterSpace), we may BLAST instead. Therefore this message should eventually get retired -- don't use. See OrderSpec::follows for the properties a partial order must satisfy. A full ordering must additionally satisfy: for all a, b; either a->isAfterOrEqual(b) or b->isAfterOrEqual(a)." self passe! {BooleanVar} isGE: other {Position} "OBSOLETE. Use the OrderSpec, or non-polymorphic subclass methods. Defines a transitive partial order; return false if incompatible. See OrderSpec::follows for the properties a partial order must satisfy. The ordering according to isGE is the same as the ascending OrderSpec for this coordinate space. It is probably better to use the OrderSpec than this message." self passe! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Position class instanceVariableNames: ''! (Position getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; yourself)! !Position class methodsFor: 'smalltalk: system'! info.stProtocol "{XuRegion CLIENT} asRegion {CoordinateSpace CLIENT} coordinateSpace "! !Position subclass: #FilterPosition instanceVariableNames: 'myRegion {XnRegion}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-filter'! FilterPosition comment: 'Encapsulates a Region in the baseSpace into a Position so that it can be treated as one for polymorphism. See Filter.'! (FilterPosition getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #ON.CLIENT; add: #COPY; yourself)! !FilterPosition methodsFor: 'testing'! {UInt32} actualHashForEqual ^myRegion hashForEqual + 1! {BooleanVar} isEqual: other {Heaper} other cast: FilterPosition into: [:rap | ^rap baseRegion isEqual: myRegion] others: [^false]. ^false "fodder"! ! !FilterPosition methodsFor: 'accessing'! {XnRegion} asRegion ^(Filter subsetFilter: self coordinateSpace with: myRegion) intersect: (Filter supersetFilter: self coordinateSpace with: myRegion)! {XnRegion CLIENT INLINE} baseRegion "Essential. The region in the base space which I represent." ^myRegion! {CoordinateSpace} coordinateSpace ^FilterSpace make: myRegion coordinateSpace! ! !FilterPosition methodsFor: 'instance creation'! create: region {XnRegion} super create. myRegion _ region.! ! !FilterPosition methodsFor: 'smalltalk: passe'! {XnRegion} region self passe! ! !FilterPosition methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myRegion _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myRegion.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FilterPosition class instanceVariableNames: ''! (FilterPosition getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #ON.CLIENT; add: #COPY; yourself)! !FilterPosition class methodsFor: 'pseudo constructors'! make: region {XnRegion} "A position containing the given region." ^FilterPosition create: region! ! !FilterPosition class methodsFor: 'smalltalk: system'! info.stProtocol "{XnRegion CLIENT} baseRegion "! !Position subclass: #ID instanceVariableNames: ' mySpace {IDSpace | NULL} myBackend {Sequence | NULL} myNumber {IntegerVar}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Basic'! ID comment: 'Implementation note: An ID exists within a particular IDSpace, and is generated by a particular Server. It holds onto the space and the Server which created it, along with a number identifying the ID uniquely. If mySpace is NULL, then the ID is in the global IDSpace. If myBackend is NULL, then this ID was generated by the current Server (unless myNumber is negative, in which case it is considered to have been generated by the "global" backend). If myBackend is non-NULL, then myNumber must be non-negative.'! (ID getOrMakeCxxClassDescription) friends: 'friend class IDRegion; friend class IDStepper; friend class IDUpOrder; friend class IDTester; friend class IDSpace; '; attributes: ((Set new) add: #CONCRETE; add: #ON.CLIENT; add: #COPY; yourself)! !ID methodsFor: 'accessing'! {XnRegion} asRegion myBackend == NULL ifTrue: [^IDRegion make: mySpace with: (IntegerRegion make: myNumber) with: NULL with: false] ifFalse: [ | others {MuTable of: Sequence and: IntegerRegion} | others := MuTable make: SequenceSpace make. others at: myBackend introduce: (IntegerRegion make: myNumber). ^IDRegion make: mySpace with: IntegerRegion make with: others asImmuTable with: false].! {CoordinateSpace} coordinateSpace mySpace == NULL ifTrue: [^IDSpace global]. ^mySpace! {UInt8Array CLIENT} export "Essential. Export this iD in a form which can be handed to Server::importID on any Server to generate the same ID" | xmtr {SpecialistXmtr} result {WriteVariableArrayStream} | result := WriteVariableArrayStream make: 200. xmtr := Binary2XcvrMaker make makeXmtr: (TransferSpecialist make: Cookbook make) with: result. ID exportSequence: xmtr with: (self coordinateSpace cast: IDSpace) backend. xmtr sendIntegerVar: (self coordinateSpace cast: IDSpace) spaceNumber. ID exportSequence: xmtr with: self backend. xmtr sendIntegerVar: self number. ^result array! ! !ID methodsFor: 'comparing'! {UInt32} actualHashForEqual | result {UInt32} | result := self getCategory hashForEqual. mySpace ~~ NULL ifTrue: [result := result bitXor: mySpace hashForEqual]. myBackend ~~ NULL ifTrue: [result := result bitXor: myBackend hashForEqual]. ^result bitXor: myNumber DOThashForEqual! {BooleanVar} isEqual: heaper {Heaper} heaper cast: ID into: [ :other | mySpace == NULL ifTrue: [other fetchSpace == NULL ifFalse: [^false]] ifFalse: [(other fetchSpace ~~ NULL and: [mySpace isEqual: other fetchSpace]) ifFalse: [^false]]. myBackend == NULL ifTrue: [other fetchBackend == NULL ifFalse: [^false]] ifFalse: [(other fetchBackend ~~ NULL and: [myBackend isEqual: other fetchBackend]) ifFalse: [^false]]. ^ myNumber = other number] others: [^false]. ^false "fodder"! ! !ID methodsFor: 'protected: create'! create: space {IDSpace | NULL} with: backend {Sequence | NULL} with: number {IntegerVar} super create. mySpace := space. myBackend := backend. myNumber := number.! ! !ID methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << (self coordinateSpace cast: IDSpace) identifier << ':' << self identifier! ! !ID methodsFor: 'private:'! {Sequence} backend "Essential. A Sequence identifying the server on which this was created" myBackend == NULL ifTrue: [myNumber < IntegerVarZero ifTrue: [^Sequence zero] ifFalse: [^FeServer identifier]] ifFalse: [^myBackend]! {Sequence | NULL} fetchBackend ^myBackend! {IDSpace | NULL} fetchSpace ^mySpace! {IntegerVar} number "Essential. The number identifying this ID from all others generated by the same Server in the same IDSpace." ^myNumber! ! !ID methodsFor: 'obsolete:'! {Sequence} identifier "A sequence of numbers which uniquely identify this ID within its space" Ravi thingToDo. "get rid of this, and clients" ^self backend withLast: myNumber! ! !ID methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. mySpace _ receiver receiveHeaper. myBackend _ receiver receiveHeaper. myNumber _ receiver receiveIntegerVar.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: mySpace. xmtr sendHeaper: myBackend. xmtr sendIntegerVar: myNumber.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ID class instanceVariableNames: ''! (ID getOrMakeCxxClassDescription) friends: 'friend class IDRegion; friend class IDStepper; friend class IDUpOrder; friend class IDTester; friend class IDSpace; '; attributes: ((Set new) add: #CONCRETE; add: #ON.CLIENT; add: #COPY; yourself)! !ID class methodsFor: 'module private create'! make: space {IDSpace | NULL} with: backend {Sequence | NULL} with: number {IntegerVar} ^ self create: space with: backend with: number! ! !ID class methodsFor: 'private: pseudo constructors'! {ID} usingx: space {IDSpace | NULL} with: backend {Sequence | NULL} with: number {IntegerVar} "Special for IDStepper - checks whether it should make backend be NULL" [BeGrandMap] USES. ((backend == NULL or: [backend isEqual: Sequence zero]) or: [backend isEqual: FeServer identifier]) ifTrue: [^self make: space with: NULL with: number] ifFalse: [^self make: space with: backend with: number]! ! !ID class methodsFor: 'smalltalk: passe'! {ID} key: string {char star} "ID key: 'test'" self passe.! make: pakobits {PackOBits} self passe.! make: left {IntegerVar} with: right {IntegerVar} self passe.! ! !ID class methodsFor: 'smalltalk: system'! info.stProtocol "{UInt8Array CLIENT} export "! ! !ID class methodsFor: 'creation'! {ID CLIENT login} import: data {PrimIntArray} "Essential. Take some information describing an ID and create the ID it was exported from." | rcvr {SpecialistRcvr} spaceBackend {Sequence} spaceNumber {IntegerVar} iDBackend {Sequence} iDNumber {IntegerVar} space {IDSpace} | rcvr := Binary2XcvrMaker make makeRcvr: (TransferSpecialist make: Cookbook make) with: (XnReadStream make: (data cast: UInt8Array)). spaceBackend := self importSequence: rcvr. spaceNumber := rcvr receiveIntegerVar. iDBackend := self importSequence: rcvr. iDNumber := rcvr receiveIntegerVar. space := IDSpace make: spaceBackend with: spaceNumber. (space isEqual: CurrentGrandMap fluidGet globalIDSpace) ifTrue: [space := NULL]. ^ID usingx: space with: iDBackend with: iDNumber! ! !ID class methodsFor: 'private: export/import for friends'! {void} exportIntegerRegion: xmtr {SpecialistXmtr} with: integers {IntegerRegion} "Write a IntegerRegion onto a stream" xmtr sendIntegerVar: integers isBoundedBelow not. xmtr sendIntegerVar: integers secretTransitions count. Int32Zero almostTo: integers secretTransitions count do: [ :i {Int32} | xmtr sendIntegerVar: (integers secretTransitions integerAt: i)]! {void} exportSequence: xmtr {SpecialistXmtr} with: sequence {Sequence} "Write a Sequence onto a stream" sequence isZero ifTrue: [xmtr sendIntegerVar: IntegerVarZero. ^VOID]. xmtr sendIntegerVar: sequence lastIndex - sequence firstIndex + 1. xmtr sendIntegerVar: sequence firstIndex. sequence firstIndex to: sequence lastIndex do: [ :i {IntegerVar} | xmtr sendIntegerVar: (sequence integerAt: i)].! {IntegerRegion} importIntegerRegion: rcvr {SpecialistRcvr} "Read a IntegerRegion from a stream" | startsInside {BooleanVar} n {Int32} transitions {IntegerVarArray} | startsInside := rcvr receiveIntegerVar DOTasLong. n := rcvr receiveIntegerVar DOTasLong. transitions := IntegerVarArray zeros: n. Int32Zero almostTo: n do: [ :i {Int32} | transitions at: i storeInteger: rcvr receiveIntegerVar]. ^IntegerRegion usingx: startsInside with: n with: transitions! {Sequence} importSequence: rcvr {SpecialistRcvr} "Read a Sequence from a stream" | count {IntegerVar} shift {IntegerVar} numbers {IntegerVarArray} | count := rcvr receiveIntegerVar. count == IntegerVarZero ifTrue: [^Sequence zero]. numbers := IntegerVarArray zeros: count DOTasLong. shift := rcvr receiveIntegerVar. Int32Zero almostTo: count DOTasLong do: [ :i {Int32} | numbers at: i storeInteger: rcvr receiveIntegerVar]. ^SequenceSpace make position: numbers with: shift! !Position subclass: #IntegerPos instanceVariableNames: 'myValue {IntegerVar}' classVariableNames: 'TheZero {IntegerPos} ' poolDictionaries: '' category: 'Xanadu-Spaces-Integers'! IntegerPos comment: 'Because of the constraints of C++, we have two very different types representing integers in our system. XuInteger is the boxed representation which must be used in any context which only knows that it is dealing with a Position. XuInteger is a Heaper with all that implies. Specifically, one can take advantage of all the advantages of polymorphism (leading to uses by code that only knows it is dealing with a Position), but at the cost of representing each value by a heap allocated object to which pointers are passed. Such a representation is referred to as "boxed" because the pointer combined with the storage structure overhead of maintaining a heap allocated object constitutes a "box" between the user of the data (the guy holding onto the pointer), and the actual data (which is inside the Heaper). In contrast, IntegerVar is the efficient, unboxed representation of an integer. (actually, it is only unboxed so long as it fits within some size limit such as 32 bits. Those IntegerVars that exceed this limit pay their own boxing cost to store their representation on the heap. This need not concern us here.) See "The Var vs Heaper distinction" and IntegerVar. When we know that we are dealing specifically with an integer, we`d like to be able to stick with IntegerVars without having to convert them to XuIntegers. However, we`d like to be able to do everything that we could normally do if we had an XuInteger. For this purpose, many messages (such as Position * Dsp::of(Position*)) have an additional overloading (IntegerVar Dsp::of(IntegerVar)) whose semantics is defined in terms of converting the argument to an XuInteger, applying the original operation, and converting the result (which is asserted to be an XuInteger) back to an IntegerVar. Dsp even provides a default implementation to do exactly that. However, if we actually rely on this default implementation then we are defeating the whole purpose of avoiding boxing overhead. Instead, IntegerDsp overrides this to provide an efficient implementation. Any particular case may at the moment simply be relying on the default. The point is to get interfaces defined early which allow efficiency tuning to proceed in a modular fashion later. Should any particular reliance on the default actually prove to be an efficiency issue, we will deal with it then.'! (IntegerPos getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #ON.CLIENT; add: #COPY; yourself)! !IntegerPos methodsFor: 'testing'! {UInt32} actualHashForEqual "This must use an external function so other parts of the system can compute the hash from an integerVar without boxing." "Open-code in smalltalk because we don't have inlines." "NOTE: Do NOT change this without also changing the implementation of integerHash!!!!!!." [^(((myValue DOTasLong * 99991) lo3bytes) bitXor: 98953) "bitShiftRight: 6"] smalltalkOnly. [^IntegerPos integerHash: myValue] translateOnly! {BooleanVar} isEqual: other {Heaper} other cast: IntegerPos into: [:xui | ^xui asIntegerVar = myValue] others: [^false]. ^ false "compiler fodder"! {BooleanVar} isGE: other {Position} "Just the full ordering you'd expect on integers" other cast: IntegerPos into: [:xui | ^myValue >= xui asIntegerVar] others: [Heaper BLAST: #CantMixCoordinateSpaces]. ^ false "compiler fodder"! ! !IntegerPos methodsFor: 'accessing'! {Int32 INLINE} asInt32 "Unboxed version as an integer. See class comment" ^myValue DOTasLong! {IntegerVar INLINE} asIntegerVar "Essential. Unboxed version. See class comment" ^myValue! {XnRegion} asRegion ^IntegerRegion make: self asIntegerVar! {CoordinateSpace INLINE} coordinateSpace ^ IntegerSpace make! {IntegerVar CLIENT INLINE} value "Essential. Unboxed version. See class comment" ^myValue! ! !IntegerPos methodsFor: 'smalltalk: private:'! basicCast: someClass someClass == Character ifTrue: [^ Character value: myValue] ifFalse: [^self]! ! !IntegerPos methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << 'I(' << myValue << ')'! ! !IntegerPos methodsFor: 'protected: creation'! create: newValue {IntegerVar} super create. myValue _ newValue! ! !IntegerPos methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myValue _ receiver receiveIntegerVar.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendIntegerVar: myValue.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! IntegerPos class instanceVariableNames: ''! (IntegerPos getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #ON.CLIENT; add: #COPY; yourself)! !IntegerPos class methodsFor: 'pseudo constructors'! {IntegerPos INLINE} make: newValue {IntegerVar} "Box an integer. See XuInteger class comment. you can also create an integer in smalltalk by sending the integer message to a Smalltalk integer" ^IntegerPos create: newValue! {IntegerPos INLINE} zero "Box an integer. See XuInteger class comment. you can also create an integer in smalltalk by sending the integer message to a Smalltalk integer. This should return the canonical zero eventually." ^IntegerPos make: IntegerVarZero! ! !IntegerPos class methodsFor: 'smalltalk: smalltalk pseudoconstructors'! IntegerVar: number ^ number! ! !IntegerPos class methodsFor: 'hash computing'! {UInt32 INLINE} integerHash: value {IntegerVar} "NOTE: Do NOT change this without also changing the implementation of hashForEqual in XuInteger!!!!!!." [^(((value * 99991) lo3bytes) bitXor: 98953) "bitShiftRight: 6"] smalltalkOnly. [^(((value * 99991) DOTasLong bitAnd: 16777215) bitXor: 98953) "bitShiftRight: 6"] translateOnly.! ! !IntegerPos class methodsFor: 'smalltalk: system'! info.stProtocol "{IntegerVar CLIENT INLINE} value "! ! !IntegerPos class methodsFor: 'smalltalk: promise'! exportName ^'Integer'! !Position subclass: #RealPos instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-tumbler'! RealPos comment: 'Represents some real number exactly. Not all real numbers can be exactly represented. See class comment in RealSpace.'! (RealPos getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; add: #COPY; yourself)! !RealPos methodsFor: 'accessing'! {XnRegion} asRegion ^RealRegion make: false with: (PrimSpec pointer arrayWithTwo: (BeforeReal make: self) with: (AfterReal make: self))! {CoordinateSpace INLINE} coordinateSpace ^RealSpace make! {PrimFloatValue CLIENT} value "Essential. Return the number as a PrimFloat object from which you can get it in a variety of representations." self subclassResponsibility! ! !RealPos methodsFor: 'testing'! {UInt32} actualHashForEqual [^self asIEEE64 basicCast: UInt32] translateOnly. [^self asIEEE64 truncated] smalltalkOnly! {BooleanVar} isEqual: other {Heaper} MarkM thingToDo. "128 bit values" other cast: RealPos into: [:r | ^self asIEEE64 = r asIEEE64] others: [^false]. ^false "fodder"! {BooleanVar} isGE: other {Position} ^self asIEEE64 >= (other cast: RealPos) asIEEE64! ! !RealPos methodsFor: 'smalltalk: passe'! {IntegerVar} exponent self passe! {BooleanVar} isIEEE "Whether the real number that this object represents is exactly representable in an available IEEE precision. Currently the answer is always TRUE, and the available precisions are 8 (stupid precision), 32 (single precision), and 64 (double precision). If the answer is FALSE, the meaning of the messages 'precision' and 'asIEEE' remain to be defined." self passe. ^true! {IntegerVar} mantissa "This number represents exactly this->mantissa() * 2 ^ this->exponent(). Should we eventually support real numbers which cannot be expressed exactly with integral mantissa and exponent, then this message (and 'exponent') will BLAST for such numbers." self passe! ! !RealPos methodsFor: 'obsolete:'! {IEEE64} asIEEE "Returns the value as IEEE basic data type is big enough to hold any value which can be put into an XuReal. Currently this is an IEEE64 (double precision). In future releases of this API, the return type of this method may be changed to IEEE128 (quad precision). Once we support other ways of representing real numbers, there may not be an all-inclusive IEEE type, in which case this message will BLAST. The only IEEE values which this will return are those that represent real numbers. I.e., no NANs, no inifinities, no negative zero." self subclassResponsibility! {IEEE64} asIEEE64 "Returns the value as IEEE64 (double precision). The only IEEE values which this will return are those that represent real numbers. I.e., no NANs, no inifinities, no negative zero." self subclassResponsibility! {Int32} precision "What precision is it, in terms of the number of bits used to represent it. In the interests of efficiency, this may return a number larger than that *needed* to represent it. However, the precision reported must be at least that needed to represent this number. It is assumed that the format of the number satisfies the IEEE radix independent floating point spec. Should we represent real numbers other that those representable in IEEE, the meaning of this message will be more fully specified. The fact that this message is allowed to overestimate precision doesn't interfere with equality: a->isEqual(b) exactly when they represent that same real number, even if one of them happens to overestimate precision more that the other." MarkM thingToDo. "retire this" self subclassResponsibility! ! !RealPos methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RealPos class instanceVariableNames: ''! (RealPos getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; add: #COPY; yourself)! !RealPos class methodsFor: 'creation'! {RealPos INLINE} make: value {IEEE64} "make an XuReal given an IEEE floating point number of whatever precision on this platform is able to hold all the real numbers currently representable by an XuReal. Currently this is IEEE64 (double precision), but may be redeclared as a larger IEEE precision in the future. See comment in XuReal::makeIEEE64" ^self makeIEEE64: value! {RealPos} makeIEEE32: value {IEEE32} "See comment in XuReal::makeIEEE64" self knownBug. "must ensure that it is a number, and convert -0 to +0" self thingToDo. "perhaps we should check to see if a lower precision can hold it exactly, and delegate to XuIEEE8. Nahh." ^IEEE32Pos create: value! {RealPos} makeIEEE64: value {IEEE64} "Returns an XuReal which exactly represents the same real number that is represented by 'value'. BLASTs if value doesn't represent a real (i.e., no NANs or inifinities). Negative 0 will be silently converted to positive zero" self knownBug. "must ensure that it is a number, and convert -0 to +0" self thingToDo. "perhaps we should check to see if a lower precision can hold it exactly, and delegate to XuIEEE32 or XuIEEE8. Nahh." ^IEEE64Pos create: value! {RealPos} makeIEEE8: value {IEEE8} "See comment in XuReal::makeIEEE64" self knownBug. "must ensure that it is a number, and convert -0 to +0" ^IEEE8Pos create: value! ! !RealPos class methodsFor: 'smalltalk: system'! info.stProtocol "{PrimFloat CLIENT} value "! ! !RealPos class methodsFor: 'smalltalk: promise'! exportName ^'Real'! !RealPos subclass: #IEEE32Pos instanceVariableNames: 'myValue {IEEE32}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-tumbler'! IEEE32Pos comment: 'For representing exactly those real numbers that can be represented in IEEE single precision'! (IEEE32Pos getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !IEEE32Pos methodsFor: 'creation'! create: value {IEEE32} super create. myValue := value! ! !IEEE32Pos methodsFor: 'obsolete:'! {IEEE64} asIEEE [^myValue basicCast: IEEE64] translateOnly. [^myValue asDouble] smalltalkOnly! {IEEE64} asIEEE64 [^myValue basicCast: IEEE64] translateOnly. [^myValue asDouble] smalltalkOnly! {Int32} precision ^32! ! !IEEE32Pos methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << '<' << myValue << '>'! ! !IEEE32Pos methodsFor: 'accessing'! {PrimFloatValue} value ^ PrimIEEE32 make: myValue! ! !IEEE32Pos methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myValue _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myValue.! !RealPos subclass: #IEEE64Pos instanceVariableNames: 'myValue {IEEE64}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-tumbler'! IEEE64Pos comment: 'For representing exactly those real numbers that can be represented in IEEE double precision'! (IEEE64Pos getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !IEEE64Pos methodsFor: 'creation'! create: value {IEEE64} super create. myValue := value! ! !IEEE64Pos methodsFor: 'obsolete:'! {IEEE64} asIEEE ^myValue! {IEEE64} asIEEE64 ^myValue! {Int32} precision ^64! ! !IEEE64Pos methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << '<' << myValue << '>'! ! !IEEE64Pos methodsFor: 'accessing'! {PrimFloatValue} value ^ PrimIEEE64 make: myValue! ! !IEEE64Pos methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myValue _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myValue.! !RealPos subclass: #IEEE8Pos instanceVariableNames: 'myValue {IEEE8}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-tumbler'! IEEE8Pos comment: 'For representing exactly those real numbers that can be represented in IEEE stupid precision'! (IEEE8Pos getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !IEEE8Pos methodsFor: 'creation'! create: value {IEEE8} super create. myValue := value! ! !IEEE8Pos methodsFor: 'obsolete:'! {IEEE64} asIEEE MarkM shouldImplement. ^0.0 "fodder"! {IEEE64} asIEEE64 MarkM shouldImplement. ^0.0 "fodder"! {Int32} precision ^8! ! !IEEE8Pos methodsFor: 'accessing'! {PrimFloatValue} value MarkM shouldImplement. ^NULL "fodder"! ! !IEEE8Pos methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myValue _ receiver receiveInt32.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendInt32: myValue.! !Position subclass: #Sequence instanceVariableNames: ' myShift {IntegerVar} myNumbers {PrimIntegerArray}' classVariableNames: 'TheZero {Sequence} ' poolDictionaries: '' category: 'Xanadu-tumbler'! Sequence comment: 'Represents an infinite sequence of integers (of which only a finite number can be non-zero). They are lexically ordered, and there is a "decimal point" between the numbers at -1 and 0. Implementation note: The array should have no zeros at either end, and noone else should have a pointer to it.'! (Sequence getOrMakeCxxClassDescription) friends: '/* friends for class Sequence */ friend class AfterSequence; friend class BeforeSequence; friend class BeforeSequencePrefix; friend class SequenceUpOrder; friend class SequenceSpace;'; attributes: ((Set new) add: #CONCRETE; add: #ON.CLIENT; add: #COPY; yourself)! !Sequence methodsFor: 'accessing'! {XnRegion} asRegion ^SequenceRegion usingx: false with: ((PrimSpec pointer arrayWithTwo: (BeforeSequence make: self) with: (AfterSequence make: self)) cast: PtrArray)! {CoordinateSpace INLINE} coordinateSpace ^SequenceSpace make! {IntegerVar INLINE} count "How many numbers in the sequence, not counting leading or trailing zeros" ^myNumbers count! {IntegerVar CLIENT} firstIndex "The smallest index with a non-zero number. Blasts if it is all zeros." myNumbers count = Int32Zero ifTrue: [Heaper BLAST: #ZeroSequence]. ^myShift! {IntegerVar CLIENT} integerAt: index {IntegerVar} "The number at the given index in the Sequence. Returns zeros beyond either end of the array." | i {IntegerVar} | i := index - myShift. (i >= IntegerVarZero and: [i < self count]) ifTrue: [^myNumbers integerAt: i DOTasLong] ifFalse: [^IntegerVarZero]! {PrimIntegerArray CLIENT} integers "Essential. The numbers in this Sequence. This is a copy of the array, so you may modify it. Note that two Sequences which are isEqual, may actually have arrays of numbers which have different specs. Also, the array will not have any zeros at the beginning or end." ^myNumbers copy cast: PrimIntegerArray! {BooleanVar CLIENT} isZero "Whether all the numbers in the sequence are zero" ^myNumbers count == Int32Zero! {IntegerVar CLIENT} lastIndex "The largest index with a non-zero number. Blasts if it is all zeros." myNumbers count = Int32Zero ifTrue: [Heaper BLAST: #ZeroSequence]. ^myShift + myNumbers count - 1! {IntegerVar INLINE} shift "The amount by which the numbers are shifted. Positive means less significant, negative means more significant. This is contrary to the usual arithmetic notions, but it is the right thing for arrays." ^myShift! ! !Sequence methodsFor: 'private: comparing'! {Int32} comparePrefix: other {Sequence} with: n {IntegerVar} "Compare my numbers up to and including index n with the corresponding numbers in the other Sequence. Return -1, 0 or 1 depending on whether they are <, =, or > the other." | diff {IntegerVar} | (self isZero or: [myShift > n]) ifTrue: [(other isZero or: [other shift > n]) ifTrue: [^Int32Zero]. (other secretNumbers integerAt: Int32Zero) > IntegerVarZero ifTrue: [^-1] ifFalse: [^1]]. (other isZero or: [other shift > n]) ifTrue: [(myNumbers integerAt: Int32Zero) > IntegerVarZero ifTrue: [^1] ifFalse: [^-1]]. diff := myShift - other shift. diff < IntegerVarZero ifTrue: [(myNumbers integerAt: Int32Zero) > IntegerVarZero ifTrue: [^1] ifFalse: [^-1]]. diff > IntegerVarZero ifTrue: [(other secretNumbers integerAt: Int32Zero) > IntegerVarZero ifTrue: [^-1] ifFalse: [^1]]. ^myNumbers compare: other secretNumbers with: (n - myShift + 1 min: (myNumbers count max: other secretNumbers count)) DOTasLong! ! !Sequence methodsFor: 'testing'! {UInt32} actualHashForEqual ^myShift DOTasLong bitXor: myNumbers elementsHash! {BooleanVar} isEqual: other {Heaper} other cast: Sequence into: [ :sequence | ^myShift = sequence shift and: [myNumbers contentsEqual: sequence secretNumbers]] others: [^false]. ^ false "compiler fodder"! {BooleanVar} isGE: other {Position} "Whether this sequence is greater than or equal to the other sequence, using a lexical comparison of their corresponding numbers." | o {Sequence} | o _ other cast: Sequence. (self isZero) ifTrue: [^o isZero or: [(o secretNumbers integerAt: Int32Zero) <= IntegerVarZero]]. (o isZero or: [myShift < o shift]) ifTrue: [^self isZero or: [(myNumbers integerAt: Int32Zero) >= IntegerVarZero]]. myShift > o shift ifTrue: [^(o secretNumbers integerAt: Int32Zero) <= IntegerVarZero]. myShift < o shift ifTrue: [^(myNumbers integerAt: Int32Zero) >= IntegerVarZero]. ^(myNumbers compare: o secretNumbers) >= Int32Zero! ! !Sequence methodsFor: 'private:'! {PrimIntegerArray INLINE} secretNumbers "The array itself, for internal use" ^myNumbers! ! !Sequence methodsFor: 'printing'! {void} printOn: oo {ostream reference} Sequence printOn: oo with: myShift with: myNumbers! ! !Sequence methodsFor: 'create'! create: shift {IntegerVar} with: numbers {PrimIntegerArray} super create. myShift := shift. myNumbers := numbers.! ! !Sequence methodsFor: 'operations'! {Sequence} first "The sequence consisting of all numbers in this one up to but not including the first zero, or the entire thing if there are no zeros" "| zero {Int32} | zero := myNumbers indexOfInteger: IntegerVarZero. zero < Int32Zero ifTrue: [^self] ifFalse: [^Sequence create: ((myNumbers copy: zero) cast: PrimIntegerArray)]" Someone shouldImplement. ^NULL "fodder"! {Sequence} minus: other {Sequence} "A sequence with the corresponding numbers subtracted from each other" | diff {Int32} result {PrimIntegerArray} | Ravi thingToDo. "Only increase representation size when necessary" Ravi knownBug. "large difference in shifts creates huge array" diff := (other shift - myShift) DOTasLong. diff > Int32Zero ifTrue: [result := (PrimSpec integerVar copyGrow: myNumbers with: (diff + other secretNumbers count - myNumbers count max: Int32Zero)) cast: PrimIntegerArray. result at: diff subtractElements: other secretNumbers. ^Sequence usingx: myShift with: result] ifFalse: [result := (PrimSpec integerVar copy: myNumbers with: -1 with: Int32Zero with: diff negated with: ((other shift + other count - (myShift + myNumbers count)) DOTasLong max: Int32Zero)) cast: PrimIntegerArray. result at: diff negated subtractElements: other secretNumbers. ^Sequence usingx: other shift with: result]! {Sequence} plus: other {Sequence} "A sequence with the corresponding numbers added to each other" | diff {Int32} result {PrimIntegerArray} | Ravi thingToDo. "Only increase representation size when necessary" Ravi knownBug. "large difference in shifts creates huge array" diff := (other shift - myShift) DOTasLong. diff > Int32Zero ifTrue: [result := (PrimSpec integerVar copyGrow: myNumbers with: (diff + other secretNumbers count - myNumbers count max: Int32Zero)) cast: PrimIntegerArray. result at: diff addElements: other secretNumbers. ^Sequence usingx: myShift with: result] ifFalse: [result := (PrimSpec integerVar copy: myNumbers with: -1 with: Int32Zero with: diff negated with: ((other shift + other count - (myShift + myNumbers count)) DOTasLong max: Int32Zero)) cast: PrimIntegerArray. result at: Int32Zero addElements: other secretNumbers. ^Sequence usingx: other shift with: result]! {Sequence} rest "The sequence consisting of all numbers in this one after but not including the first zero, or a null sequence if there are no zeros" "| zero {Int32} | zero := myNumbers indexOfInteger: IntegerVarZero. zero < Int32Zero ifTrue: [^Sequence zero] ifFalse: [^Sequence create: ((myNumbers copy: -1 with: 1 + zero) cast: PrimIntegerArray)]" Someone shouldImplement. ^NULL "fodder"! {Sequence} shift: offset {IntegerVar} "Shift the numbers by some number of places. Positive shifts make it less significant, negative shifts make it more significant." (offset == IntegerVarZero or: [myNumbers count == Int32Zero]) ifTrue: [^self]. ^Sequence create: myShift + offset with: myNumbers! {Sequence CLIENT} with: index {IntegerVar} with: number {IntegerVar} "Change a single element of the sequence." (index >= myShift and: [index - myShift < myNumbers count]) ifTrue: [number = IntegerVarZero ifTrue: [index = myShift ifTrue: [^Sequence create: myShift + 1 with: ((myNumbers copy: myNumbers count - 1 with: 1) cast: PrimIntegerArray)]. index = (myShift + myNumbers count) ifTrue: [^Sequence create: myShift + 1 with: ((myNumbers copy: myNumbers count - 1) cast: PrimIntegerArray)]]. ^Sequence create: myShift with: (myNumbers at: (index - myShift) DOTasLong hold: number)]. number = IntegerVarZero ifTrue: [^self]. index < myShift ifTrue: [ | result {PrimIntegerArray} | result := (((myNumbers spec cast: PrimIntegerSpec) combine: ((PrimSpec toHold: number) cast: PrimIntegerSpec)) copy: myNumbers with: -1 with: Int32Zero with: (myShift - index) DOTasLong) cast: PrimIntegerArray. result at: Int32Zero storeInteger: number. ^Sequence create: index with: result]. ^Sequence create: myShift with: (myNumbers at: (index - myShift) DOTasLong hold: number)! {Sequence} withFirst: number {IntegerVar} "A Sequence with all my numbers followed by the given one" Ravi shouldImplement. ^NULL "fodder"! {Sequence} withLast: number {IntegerVar} "A Sequence with all my numbers followed by the given one" ^Sequence create: myShift with: (myNumbers at: myNumbers count hold: number)! {Sequence} withRest: other {Sequence} "A sequence containing all the numbers in this one, followed by the other one, separated by a single zero." | spec {PrimIntegerSpec} result {PrimIntegerArray} | spec := (myNumbers spec cast: PrimIntegerSpec) combine: (other secretNumbers spec cast: PrimIntegerSpec). result := (spec copyGrow: myNumbers with: other count DOTasLong + 1) cast: PrimIntegerArray. result at: self count DOTasLong + 1 storeMany: other secretNumbers. ^Sequence create: myShift with: result! ! !Sequence methodsFor: 'smalltalk: passe'! {BooleanVar} isEmpty "Whether there are no non-zero numbers in the Sequence" self passe. ^myNumbers count == Int32Zero! {IntegerVar} numberAt: index {IntegerVar} self passe "integerAt"! {PrimIntegerArray} numbers self passe. "integers"! ! !Sequence methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myShift _ receiver receiveIntegerVar. myNumbers _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendIntegerVar: myShift. xmtr sendHeaper: myNumbers.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Sequence class instanceVariableNames: ''! (Sequence getOrMakeCxxClassDescription) friends: '/* friends for class Sequence */ friend class AfterSequence; friend class BeforeSequence; friend class BeforeSequencePrefix; friend class SequenceUpOrder; friend class SequenceSpace;'; attributes: ((Set new) add: #CONCRETE; add: #ON.CLIENT; add: #COPY; yourself)! !Sequence class methodsFor: 'pseudo constructors'! {Sequence} numbers: digits {PrimIntegerArray} |first {Int32} last {Int32} | first := digits indexPastInteger: IntegerVarZero. first = -1 ifTrue: [^ Sequence zero]. last := digits indexPastInteger: IntegerVarZero with: -1 with: -1. ^ self create: first with: ((digits copy: last - first + 1 with: first) cast: PrimIntegerArray)! {Sequence} one: a {IntegerVar} "A single element Sequence" a = IntegerVarZero ifTrue: [^self zero]. ^self create: IntegerVarZero with: ((PrimSpec integerVar arrayWith: (PrimSpec integerVar value: a)) cast: PrimIntegerArray)! {Sequence} string: string {Character star} ^self create: IntegerVarZero with: (UInt8Array string: string)! {Sequence} three: a {IntegerVar} with: b {IntegerVar} with: c {IntegerVar} "A three element Sequence" c = IntegerVarZero ifTrue: [^self two: a with: b]. ^self create: IntegerVarZero with: ((PrimSpec integerVar arrayWithThree: (PrimSpec integerVar value: a) with: (PrimSpec integerVar value: b) with: (PrimSpec integerVar value: c)) cast: PrimIntegerArray)! {Sequence} two: a {IntegerVar} with: b {IntegerVar} "A two element Sequence" b = IntegerVarZero ifTrue: [^self one: a]. ^self create: IntegerVarZero with: ((PrimSpec integerVar arrayWithTwo: (PrimSpec integerVar value: a) with: (PrimSpec integerVar value: b)) cast: PrimIntegerArray)! {Sequence INLINE} zero ^TheZero! ! !Sequence class methodsFor: 'private:'! {void} printArrayOn: oo {ostream reference} with: numbers {PrimIntegerArray} "Print a sequence of numbers separated by dots. Deal with strings specially." (numbers isKindOf: UInt8Array) ifTrue: [oo << '<' << numbers << '>'] ifFalse: [Int32Zero almostTo: numbers count do: [ :i {Int32} | i > Int32Zero ifTrue: [oo << '.']. oo << (numbers integerAt: i)]]! {void} printOn: oo {ostream reference} with: shift {IntegerVar} with: numbers {PrimIntegerArray} "Print a sequence of numbers separated by dots. Deal with strings specially." shift < numbers count negated ifTrue: [self printArrayOn: oo with: numbers. oo << '.'. self printZerosOn: oo with: shift negated - numbers count. oo << '!!0'] ifFalse: [shift < IntegerVarZero ifTrue: [self printArrayOn: oo with: ((numbers copy: shift negated DOTasLong) cast: PrimIntegerArray). oo << '!!'. self printArrayOn: oo with: ((numbers copy: -1 with: shift negated DOTasLong) cast: PrimIntegerArray)] ifFalse: [oo << '0!!'. shift > IntegerVarZero ifTrue: [self printZerosOn: oo with: shift. oo << '.']. self printArrayOn: oo with: numbers]]! {void} printZerosOn: oo {ostream reference} with: shift {IntegerVar} "Print a sequence of zeros separated by dots. Deal with large numbers specially." shift > 7 ifTrue: [oo << '...(' << shift << ')...'] ifFalse: [IntegerVarZero almostTo: shift - 1 do: [ :i {IntegerVar} | oo << '0.']. oo << '0']! {Sequence} usingx: shift {IntegerVar} with: numbers {PrimIntegerArray} "Don't need to make a copy of the array" | start {Int32} stop {Int32} | start := numbers indexPastInteger: IntegerVarZero. start < Int32Zero ifTrue: [^self zero]. stop := numbers indexPastInteger: IntegerVarZero with: -1 with: -1. (start ~= Int32Zero or: [stop < (numbers count - 1)]) ifTrue: [^self create: shift + start with: ((numbers copy: stop - start with: start) cast: PrimIntegerArray)] ifFalse: [^self create: shift with: numbers]! ! !Sequence class methodsFor: 'smalltalk: init'! initTimeNonInherited self REQUIRES: IntegerVarArray. TheZero := self create: IntegerVarZero with: (IntegerVarArray zeros: Int32Zero).! linkTimeNonInherited TheZero := NULL.! ! !Sequence class methodsFor: 'smalltalk: system'! info.stProtocol "{IntegerVar CLIENT} firstIndex {IntegerVar CLIENT} integerAt: index {IntegerVar} {PrimIntegerArray CLIENT} integers {BooleanVar CLIENT} isZero {IntegerVar CLIENT} lastIndex {Sequence CLIENT} with: index {IntegerVar} with: number {IntegerVar} "! !Position subclass: #Tuple instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Spaces-Cross'! Tuple comment: 'A tuple is a Position in a CrossSpace represented by a sequence of Positions in its subSpaces'! (Tuple getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; add: #COPY; yourself)! !Tuple methodsFor: 'printing'! {void} printOn: oo {ostream reference} self printOnWithSimpleSyntax: oo with: '<' with: ', ' with: '>'! {void} printOnWithSimpleSyntax: oo {ostream reference} with: openString {char star} with: sep {char star} with: closeString {char star} | coords {PtrArray of: Position} | oo << openString. coords := self coordinates. Int32Zero almo