'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 almostTo: coords count do: [:i {Int32} | i > Int32Zero ifTrue: [oo << sep]. (coords fetch: i) printOn: oo]. oo << closeString! ! !Tuple methodsFor: 'accessing'! {XnRegion} asRegion self subclassResponsibility! {Position CLIENT} coordinate: index {Int32} "The position with in a subspace" ^(self coordinates fetch: index) cast: Position! {PtrArray CLIENT of: Position} coordinates "Essential. An array of the coordinates in each sub space" self subclassResponsibility! {CoordinateSpace} coordinateSpace self subclassResponsibility! ! !Tuple methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! {BooleanVar} isEqual: other {Heaper} self subclassResponsibility! ! !Tuple methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Tuple class instanceVariableNames: ''! (Tuple getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; add: #COPY; yourself)! !Tuple class methodsFor: 'pseudoconstructors'! make: coordinates {PtrArray of: Position} ^ActualTuple make: (coordinates copy cast: PtrArray)! {Tuple} two: zero {Position} with: one {Position} ^ActualTuple make: ((PrimSpec pointer arrayWithTwo: zero with: one) cast: PtrArray)! ! !Tuple class methodsFor: 'smalltalk: system'! info.stProtocol "{Position CLIENT} coordinate: index {Int32} {PtrArray CLIENT of: Position} coordinates "! !Tuple subclass: #ActualTuple instanceVariableNames: 'myCoordinates {PtrArray of: Position}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Spaces-Cross'! ActualTuple comment: 'Default implementation of position in a crossed coordinate space. NOT.A.TYPE'! (ActualTuple getOrMakeCxxClassDescription) friends: 'friend class GenericCrossDsp; '; attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !ActualTuple methodsFor: 'accessing'! {XnRegion} asRegion | result {PtrArray of: XnRegion} | result := PtrArray nulls: myCoordinates count. Int32Zero almostTo: result count do: [:i {Int32} | result at: i store: (self coordinate: i) asRegion]. ^GenericCrossRegion make: (self coordinateSpace cast: CrossSpace) with: 1 with: result! {PtrArray of: Position} coordinates ^myCoordinates copy cast: PtrArray! {CoordinateSpace} coordinateSpace | result {PtrArray of: CoordinateSpace} | result := PtrArray nulls: myCoordinates count. Int32Zero almostTo: result count do: [:i {Int32} | result at: i store: (self coordinate: i) coordinateSpace]. ^CrossSpace make: result! {Int32} count ^ myCoordinates count! {Position} positionAt: dimension {Int32} ^ (myCoordinates fetch: dimension) cast: Position! ! !ActualTuple methodsFor: 'comparing'! {UInt32} actualHashForEqual ^myCoordinates contentsHash! {BooleanVar} isEqual: other {Heaper} other cast: ActualTuple into: [ :actual | ^myCoordinates contentsEqual: actual secretCoordinates] cast: Tuple into: [ :tuple | ^myCoordinates contentsEqual: tuple coordinates] others: [^false]. ^ false "compiler fodder"! ! !ActualTuple methodsFor: 'private: creation'! create: coordinates {PtrArray of: Position} super create. myCoordinates := coordinates! ! !ActualTuple methodsFor: 'private: accessing'! {PtrArray of: Position} secretCoordinates "The internal array of coordinates. Do not modify this array!!" ^myCoordinates! ! !ActualTuple methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myCoordinates _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myCoordinates.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ActualTuple class instanceVariableNames: ''! (ActualTuple getOrMakeCxxClassDescription) friends: 'friend class GenericCrossDsp; '; attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !ActualTuple class methodsFor: 'pseudoconstructors'! {Tuple} make: coordinates {PtrArray of: Position} ^self create: coordinates! !Position subclass: #UnOrdered instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Spaces-Basic'! UnOrdered comment: 'A convenient superclass of all Positions which have no natural ordering. See UnOrdered::isGE for the defining property of this class. This class should probably go away and UnOrdered::isGE distributed to the subclasses.'! (UnOrdered getOrMakeCxxClassDescription) attributes: ((Set new) add: #NOT.A.TYPE; add: #DEFERRED; yourself)! !UnOrdered methodsFor: 'accessing'! {XnRegion} asRegion self subclassResponsibility! {CoordinateSpace} coordinateSpace self subclassResponsibility! ! !UnOrdered methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! {BooleanVar} isEqual: other {Heaper} "Up in position, isGE is deferred, and isEqual is defined in terms of isEqual. Here in UnOrdered, we define isGE in terms of isEqual, so we must redefine isEqual to be deferred." self subclassResponsibility! !UnOrdered subclass: #HeaperAsPosition instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Spaces-Unordered'! HeaperAsPosition comment: 'A position in a HeaperSpace that represents the identity of some particular Heaper. See class comment in HeaperSpace.'! (HeaperAsPosition getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !HeaperAsPosition methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! {BooleanVar} isEqual: other {Heaper} self subclassResponsibility! ! !HeaperAsPosition methodsFor: 'accessing'! {XnRegion INLINE} asRegion ^HeaperRegion make.HeaperAsPosition: self! {CoordinateSpace} coordinateSpace self subclassResponsibility! {Heaper} heaper "Return the underlying Heaper whose identity (as a position) I represent. It is considered good form not to use this message. There is some controversy as to whether it will go away in the future. If you know of any good reason why it should stick around please let us know." self subclassResponsibility! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HeaperAsPosition class instanceVariableNames: ''! (HeaperAsPosition getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !HeaperAsPosition class methodsFor: 'pseudo constructors'! {HeaperAsPosition} make: heaper {Heaper} "Return a HeaperAsPosition which represents the identity of this Heaper. The resulting HeaperAsPosition will strongly retain the original Heaper against garbage collection (though not of course against manual deletion). See wimpyAsPosition" ^StrongAsPosition create: heaper! !HeaperAsPosition subclass: #StrongAsPosition instanceVariableNames: 'itsHeaper {Heaper}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Spaces-Unordered'! (StrongAsPosition getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; add: #COPY; yourself)! !StrongAsPosition methodsFor: 'testing'! {UInt32} actualHashForEqual ^itsHeaper hashForEqual! {BooleanVar} isEqual: other {Heaper} other cast: HeaperAsPosition into: [:hap | ^itsHeaper == hap heaper or: [itsHeaper isEqual: hap heaper]] others: [^false]. ^false "fodder"! ! !StrongAsPosition methodsFor: 'accessing'! {CoordinateSpace} coordinateSpace ^ HeaperSpace make! {Heaper} heaper ^ itsHeaper! ! !StrongAsPosition methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << 'position of (' << itsHeaper << ')'! ! !StrongAsPosition methodsFor: 'instance creation'! create: aHeaper {Heaper} super create. aHeaper ~~ NULL assert: 'Heapers in StrongAsPosition must be real'. itsHeaper _ aHeaper! ! !StrongAsPosition methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. itsHeaper _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: itsHeaper.! !Heaper subclass: #PrimeSizeProvider instanceVariableNames: 'smallPrimeTable {UInt32Array}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-tabtool'! PrimeSizeProvider comment: 'This is a non-stepper stepper that returns a stream of prime numbers. SCPrimeSizeProvider rejects many primes to be nice for secondary clustering at the cost of increased table size, LPPrimeSizeProvider does not claim to do this. - michael 31 July 1991'! (PrimeSizeProvider getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; yourself)! !PrimeSizeProvider methodsFor: 'accessing'! {IntegerVar} primeAfter: attempt {IntegerVar} | val {UInt32} idx {UInt32} lim {UInt32} | idx _ UInt32Zero. val _ attempt DOTasLong. lim _ smallPrimeTable count. [(idx < lim) and: [val > (smallPrimeTable uIntAt: idx)]] whileTrue: [idx _ idx + 1]. idx >= smallPrimeTable count ifTrue: [^ (attempt * 2) + 1] ifFalse: [^ Integer IntegerVar: (smallPrimeTable uIntAt: idx)]! {UInt32} uInt32PrimeAfter: attempt {UInt32} | val {UInt32} idx {UInt32} lim {UInt32} | idx _ UInt32Zero. val _ attempt. lim _ smallPrimeTable count. [(idx < lim) and: [val > (smallPrimeTable uIntAt: idx)]] whileTrue: [idx _ idx + 1]. idx >= smallPrimeTable count ifTrue: [^ (attempt * 2) + 1] ifFalse: [^ smallPrimeTable uIntAt: idx]! ! !PrimeSizeProvider methodsFor: 'creation'! create: aSmallPrimeTable {UInt32Array} super create. smallPrimeTable _ aSmallPrimeTable.! ! !PrimeSizeProvider methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PrimeSizeProvider class instanceVariableNames: ''! (PrimeSizeProvider getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; yourself)! !PrimeSizeProvider class methodsFor: 'creation'! {PrimeSizeProvider INLINE} make ^LPPrimeSizeProvider make! ! !PrimeSizeProvider class methodsFor: 'smalltalk: initialization'! initTimeNonInherited self REQUIRES: LPPrimeSizeProvider.! !PrimeSizeProvider subclass: #LPPrimeSizeProvider instanceVariableNames: '' classVariableNames: 'MySoleProvider {LPPrimeSizeProvider} ' poolDictionaries: '' category: 'Xanadu-tabtool'! LPPrimeSizeProvider comment: 'This is a non-stepper stepper that returns a stream of prime numbers. SCPrimeSizeProvider rejects many primes to be nice for secondary clustering at the cost of increased table size, LPPrimeSizeProvider does not claim to do this. - michael 31 July 1991'! (LPPrimeSizeProvider getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; yourself)! !LPPrimeSizeProvider methodsFor: 'creation'! create: aSmallPrimeTable {UInt32Array} super create: aSmallPrimeTable! ! !LPPrimeSizeProvider methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! LPPrimeSizeProvider class instanceVariableNames: ''! (LPPrimeSizeProvider getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; yourself)! !LPPrimeSizeProvider class methodsFor: 'make'! {LPPrimeSizeProvider INLINE} make ^ MySoleProvider! ! !LPPrimeSizeProvider class methodsFor: 'initialization'! {UInt32Array} primeTable | smallPrimeTable {UInt32Array} | smallPrimeTable _ UInt32Array make: 71. smallPrimeTable at: UInt32Zero storeUInt: 7. smallPrimeTable at: 1 storeUInt: 19. smallPrimeTable at: 2 storeUInt: 41. smallPrimeTable at: 3 storeUInt: 67. smallPrimeTable at: 4 storeUInt: 101. smallPrimeTable at: 5 storeUInt: 139. smallPrimeTable at: 6 storeUInt: 191. smallPrimeTable at: 7 storeUInt: 241. smallPrimeTable at: 8 storeUInt: 313. smallPrimeTable at: 9 storeUInt: 401. smallPrimeTable at: 10 storeUInt: 499. smallPrimeTable at: 11 storeUInt: 617. smallPrimeTable at: 12 storeUInt: 751. smallPrimeTable at: 13 storeUInt: 911. smallPrimeTable at: 14 storeUInt: 1091. smallPrimeTable at: 15 storeUInt: 1297. smallPrimeTable at: 16 storeUInt: 1543. smallPrimeTable at: 17 storeUInt: 1801. smallPrimeTable at: 18 storeUInt: 2113. smallPrimeTable at: 19 storeUInt: 2459. smallPrimeTable at: 20 storeUInt: 2851. smallPrimeTable at: 21 storeUInt: 3331. smallPrimeTable at: 22 storeUInt: 3833. smallPrimeTable at: 23 storeUInt: 4421. smallPrimeTable at: 24 storeUInt: 5059. smallPrimeTable at: 25 storeUInt: 5801. smallPrimeTable at: 26 storeUInt: 6607. smallPrimeTable at: 27 storeUInt: 7547. smallPrimeTable at: 28 storeUInt: 8599. smallPrimeTable at: 29 storeUInt: 9697. smallPrimeTable at: 30 storeUInt: 11004. smallPrimeTable at: 31 storeUInt: 12479. smallPrimeTable at: 32 storeUInt: 14057. smallPrimeTable at: 33 storeUInt: 15803. smallPrimeTable at: 34 storeUInt: 17881. smallPrimeTable at: 35 storeUInt: 20117. smallPrimeTable at: 36 storeUInt: 22573. smallPrimeTable at: 37 storeUInt: 28499. smallPrimeTable at: 38 storeUInt: 32003. smallPrimeTable at: 39 storeUInt: 35759. smallPrimeTable at: 40 storeUInt: 40009. smallPrimeTable at: 41 storeUInt: 44729. smallPrimeTable at: 42 storeUInt: 50053. smallPrimeTable at: 43 storeUInt: 55933. smallPrimeTable at: 44 storeUInt: 62483. smallPrimeTable at: 45 storeUInt: 69911. smallPrimeTable at: 46 storeUInt: 77839. smallPrimeTable at: 47 storeUInt: 86929. smallPrimeTable at: 48 storeUInt: 96787. smallPrimeTable at: 49 storeUInt: 108041. smallPrimeTable at: 50 storeUInt: 120473. smallPrimeTable at: 51 storeUInt: 134087. smallPrimeTable at: 52 storeUInt: 149287. smallPrimeTable at: 53 storeUInt: 166303. smallPrimeTable at: 54 storeUInt: 185063. smallPrimeTable at: 55 storeUInt: 205957. smallPrimeTable at: 56 storeUInt: 228887. smallPrimeTable at: 57 storeUInt: 254663. smallPrimeTable at: 58 storeUInt: 282833. smallPrimeTable at: 59 storeUInt: 313979. smallPrimeTable at: 60 storeUInt: 347287. smallPrimeTable at: 61 storeUInt: 384317. smallPrimeTable at: 62 storeUInt: 424667. smallPrimeTable at: 63 storeUInt: 468841. smallPrimeTable at: 64 storeUInt: 517073. smallPrimeTable at: 65 storeUInt: 569927. smallPrimeTable at: 66 storeUInt: 627553. smallPrimeTable at: 67 storeUInt: 691183. smallPrimeTable at: 68 storeUInt: 760657. smallPrimeTable at: 69 storeUInt: 836483. smallPrimeTable at: 70 storeUInt: 919757. ^ smallPrimeTable! ! !LPPrimeSizeProvider class methodsFor: 'smalltalk: initialization'! initTimeNonInherited self REQUIRES: UInt32Array. MySoleProvider _ LPPrimeSizeProvider create: self primeTable.! linkTimeNonInherited MySoleProvider _ NULL.! !Heaper subclass: #PrimIndexTable instanceVariableNames: ' myPtrs {PtrArray} myIndices {IntegerVarArray} myTally {Int4} amWimpy {BooleanVar} myOriginalSize {Int4}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-primtab'! PrimIndexTable comment: 'Map possibly wimpy pointers to integers. Common usage almost never does a remove on this class, therefore we rehash in order to save time on other ops.'! (PrimIndexTable getOrMakeCxxClassDescription) friends: '/* friends for class PrimIndexTable */ friend SPTR(PrimIndexTable) primIndexTable (Int4 size); friend SPTR(PrimIndexTable) wimpyIndexTable (Int4 size); friend class PrimIndexTableTester;'; attributes: ((Set new) add: #CONCRETE; yourself)! !PrimIndexTable methodsFor: 'accessing'! {void} at: ptr {Heaper} introduce: index {IntegerVar} | loc {Int32} | "redundant code for sake of speed" loc := self hashFind: ptr. (myPtrs fetch: loc) == NULL ifTrue: [ myIndices at: loc storeIntegerVar: index. myPtrs at: loc store: ptr] ifFalse: [Heaper BLAST: #AlreadyInTable]. myTally := myTally + 1. myTally > (myPtrs count bitShiftRight: 1) ifTrue: [ self grow ]! {void} at: ptr {Heaper} store: index {IntegerVar} | loc {Int32} | loc := self hashFind: ptr. (myPtrs fetch: loc) ~~ NULL ifFalse: [ myTally := myTally + 1 ]. myIndices at: loc storeIntegerVar: index. myPtrs at: loc store: ptr. myTally > (myPtrs count bitShiftRight: 1) ifTrue: [ self grow ]! {void} clearAll "Clear all entries from the table. I know this looks like a hack, but the alternative is to throw away the table and build a new one: an expensive prospect for comm." myPtrs count > myOriginalSize ifTrue: [myPtrs destroy. amWimpy ifTrue: [myPtrs := WeakPtrArray make: XnExecutor noopExecutor with: myOriginalSize] ifFalse: [myPtrs := PtrArray nulls: myOriginalSize]] ifFalse: [myPtrs storeAll]. myTally _ Int32Zero! {Int32 INLINE} count ^myTally! {IntegerVar} fetch: ptr {Heaper} "return -1 on not found." | loc {Int32} | loc _ self hashFindFetch: ptr. loc == -1 ifTrue: [ ^ -1 ]. ^ myIndices integerVarAt: loc! {IntegerVar} get: ptr {Heaper} | loc {Int32} | loc _ self hashFind: ptr. (myPtrs fetch: loc) == NULL ifTrue: [ Heaper BLAST: #NotInTable ]. ^ myIndices integerVarAt: loc! {void} remove: ptr {Heaper} | loc {Int32} | loc := self hashFind: ptr. (myPtrs fetch: loc) == NULL ifTrue: [ Heaper BLAST: #NotInTable ]. myPtrs at: loc store: NULL. myTally := myTally - 1. self rehash: myPtrs with: myIndices with: myPtrs count! ! !PrimIndexTable methodsFor: 'protected:'! create: size {Int32} with: wimpy {BooleanVar} super create. amWimpy := wimpy. amWimpy ifTrue: [myPtrs := WeakPtrArray make: XnExecutor noopExecutor with: size] ifFalse: [myPtrs := PtrArray nulls: size]. myIndices := IntegerVarArray zeros: size. myTally := Int32Zero. myOriginalSize := size.! {void} destruct myPtrs destroy. myIndices destroy. super destruct! ! !PrimIndexTable methodsFor: 'private:'! {void} grow self rehash: myPtrs with: myIndices with: 5 * myPtrs count // 3! {Int32} hashFind: value {Heaper} | loc {Int32} start {Int32} top {Int32} tmp {Heaper wimpy} | loc := value hashForEqual. top := myPtrs count. loc := (FHash fastHash.UInt32: loc) \\ top. start := loc. [(tmp _ myPtrs fetch: loc) ~~ NULL] whileTrue: [tmp == value ifTrue: [ ^ loc ]. loc := loc + 1. loc = start ifTrue: [ Heaper BLAST: #SanityViolation ]. loc >= top ifTrue: [loc := Int32Zero]]. ^ loc! {Int32} hashFindFetch: value {Heaper} | hashLoc {Int32} loc {Int32} top {Int32} tmp {Heaper wimpy} | value == NULL ifTrue:[ ^ -1]. hashLoc := value hashForEqual. top := myPtrs count. hashLoc := (FHash fastHash.UInt32: hashLoc) \\ top. loc := hashLoc. [(tmp _ myPtrs fetch: loc) ~~ NULL] whileTrue: [tmp == value ifTrue: [ ^ loc ]. loc := loc + 1. loc == hashLoc ifTrue: [^ -1]. loc >= top ifTrue: [loc := Int32Zero]]. ^ -1! {void} rehash: oldPtrs {PtrArray} with: oldIndices {IntegerVarArray} with: newSize {Int32} amWimpy ifTrue: [myPtrs := WeakPtrArray make: XnExecutor noopExecutor with: newSize] ifFalse: [myPtrs := PtrArray nulls: newSize]. myIndices := IntegerVarArray zeros: newSize. Int32Zero almostTo: oldPtrs count do: [:i {Int32} | | loc {Int32} | (oldPtrs fetch: i) ~~ NULL ifTrue: [loc := self hashFind: (oldPtrs fetch: i). myIndices at: loc storeIntegerVar: (oldIndices integerVarAt: i). myPtrs at: loc store: (oldPtrs fetch: i)]]. oldPtrs destroy. oldIndices destroy! ! !PrimIndexTable methodsFor: 'testing'! {UInt32} actualHashForEqual ^ myTally bitXor: myPtrs count.! ! !PrimIndexTable methodsFor: 'enumerating'! {PrimIndexTableStepper} stepper ^ PrimIndexTableStepper create: myPtrs with: myIndices with: Int32Zero! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PrimIndexTable class instanceVariableNames: ''! (PrimIndexTable getOrMakeCxxClassDescription) friends: '/* friends for class PrimIndexTable */ friend SPTR(PrimIndexTable) primIndexTable (Int4 size); friend SPTR(PrimIndexTable) wimpyIndexTable (Int4 size); friend class PrimIndexTableTester;'; attributes: ((Set new) add: #CONCRETE; yourself)! !PrimIndexTable class methodsFor: 'create'! make: size {Int32} ^ self create: size with: false! {PrimIndexTable} wimpyIndexTable: size {Int32} ^ self create: size with: true! !Heaper subclass: #PrimPtr2PtrTable instanceVariableNames: ' myFromPtrs {PtrArray} myToPtrs {PtrArray} myTally {Int4}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-primtab'! PrimPtr2PtrTable comment: 'Map wimpy pointers to strong ptrs'! (PrimPtr2PtrTable getOrMakeCxxClassDescription) friends: '/* friends for class PrimPtr2PtrTable */ friend SPTR(PrimPtr2PtrTable) primPtr2PtrTable (Int4 size);'; attributes: ((Set new) add: #CONCRETE; yourself)! !PrimPtr2PtrTable methodsFor: 'enumerating'! {PrimPtr2PtrTableStepper} stepper ^ PrimPtr2PtrTableStepper create: myFromPtrs with: myToPtrs with: Int32Zero! ! !PrimPtr2PtrTable methodsFor: 'accessing'! {void} at: key {Heaper} introduce: value {Heaper} | loc {Int32} tmp {Heaper wimpy} | loc := self hashFind: key. ((tmp _ myToPtrs fetch: loc) ~~ NULL and: [tmp ~~ PrimRemovedObject make]) ifTrue: [ Heaper BLAST: #AlreadyInTable ]. myToPtrs at: loc store: value. myFromPtrs at: loc store: key. myTally := myTally + 1. myTally > (2 * myFromPtrs count / 3) ifTrue: [ self grow ]! {void} at: key {Heaper} store: value {Heaper} | loc {Int32} | loc := self hashFind: key. (myToPtrs fetch: loc) == NULL ifTrue: [ myTally := myTally + 1]. myToPtrs at: loc store: value. myFromPtrs at: loc store: key. myTally > (2 * myFromPtrs count / 3) ifTrue: [ self grow ]! {Int32 INLINE} count ^myTally! {Heaper} fetch: key {Heaper} | tmp {Heaper wimpy} | tmp _ myToPtrs fetch: (self hashFind: key). tmp == PrimRemovedObject make ifTrue: [ ^ NULL ] ifFalse: [ ^ tmp ]! {Heaper} get: ptr {Heaper} | result {Heaper} | ((result _ myToPtrs fetch: (self hashFind: ptr)) == NULL or: [(result basicCast: Heaper star) == (PrimRemovedObject make basicCast: Heaper star)]) ifTrue: [ Heaper BLAST: #NotInTable ]. ^ result! {void} remove: key {Heaper} | loc {Int32} | loc := self hashFind: key. (myToPtrs fetch: loc) == NULL ifTrue: [ Heaper BLAST: #NotInTable ]. myToPtrs at: loc store: PrimRemovedObject make. myTally := myTally - 1.! ! !PrimPtr2PtrTable methodsFor: 'protected: destruct'! {void} destruct myFromPtrs destroy. myToPtrs destroy. super destruct! ! !PrimPtr2PtrTable methodsFor: 'protected: create'! create: size {Int32} super create. myFromPtrs := WeakPtrArray make: XnExecutor noopExecutor with: size. myToPtrs := PtrArray nulls: size. myTally := Int32Zero.! ! !PrimPtr2PtrTable methodsFor: 'private:'! {void} grow | oldFromPtrs {PtrArray} oldToPtrs {PtrArray} tmp {Heaper wimpy} removed {Heaper wimpy} | oldFromPtrs := myFromPtrs. oldToPtrs := myToPtrs. myFromPtrs := WeakPtrArray make: XnExecutor noopExecutor with: 5 * myFromPtrs count // 3. myToPtrs := PtrArray nulls: myFromPtrs count. removed _ PrimRemovedObject make. Int32Zero almostTo: oldFromPtrs count do: [:i {Int32} | | loc {Int32} | ((tmp _ oldToPtrs fetch: i) ~~ NULL and: [tmp ~~ removed]) ifTrue: [loc := self hashFind: (oldFromPtrs fetch: i). myFromPtrs at: loc store: (oldFromPtrs fetch: i). myToPtrs at: loc store: (oldToPtrs fetch: i)]]. oldFromPtrs destroy. oldToPtrs destroy! {Int32} hashFind: key {Heaper} | loc {Int32} firstRemoved {Int32} tmp {Heaper wimpy} removed {Heaper wimpy} looped {BooleanVar} | firstRemoved _ -1. loc := key hashForEqual. loc := (FHash fastHash.UInt32: loc) \\ myFromPtrs count. removed _ PrimRemovedObject make. looped _ false. [(tmp _ myToPtrs fetch: loc) ~~ NULL] whileTrue: [((myFromPtrs fetch: loc) basicCast: Heaper star) == key ifTrue: [ ^ loc ]. tmp == removed ifTrue: [firstRemoved == -1 ifTrue: [firstRemoved _ loc]]. loc := loc + 1. loc >= myFromPtrs count ifTrue: [looped ifTrue: [^firstRemoved] ifFalse: [looped _ true]. loc := Int32Zero]]. firstRemoved ~~ -1 ifTrue: [ ^ firstRemoved ] ifFalse: [ ^ loc ]! ! !PrimPtr2PtrTable methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PrimPtr2PtrTable class instanceVariableNames: ''! (PrimPtr2PtrTable getOrMakeCxxClassDescription) friends: '/* friends for class PrimPtr2PtrTable */ friend SPTR(PrimPtr2PtrTable) primPtr2PtrTable (Int4 size);'; attributes: ((Set new) add: #CONCRETE; yourself)! !PrimPtr2PtrTable class methodsFor: 'create'! make: size {Int32} ^ self create: size! !Heaper subclass: #PrimPtrTable instanceVariableNames: ' myPtrs {PtrArray} myIndices {IntegerVarArray} myTally {Int4} myExecutor {XnExecutor | NULL}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-primtab'! PrimPtrTable comment: 'Map integers to strong or weak pointers'! (PrimPtrTable getOrMakeCxxClassDescription) friends: '/* friends for class PrimPtrTable */ friend class PrimPtrTableExecutor;'; attributes: ((Set new) add: #CONCRETE; yourself)! !PrimPtrTable methodsFor: 'accessing'! {void} at: index {IntegerVar} introduce: ptr {Heaper} | loc {Int32} tmp {Heaper wimpy} | loc := self hashFind: index. ((tmp _ myPtrs fetch: loc) ~~ NULL and: [tmp ~~ PrimRemovedObject make]) ifTrue: [ Heaper BLAST: #AlreadyInTable ]. myIndices at: loc storeIntegerVar: index. myPtrs at: loc store: ptr. myTally := myTally + 1. myTally > (2 * myPtrs count / 3) ifTrue: [ self grow ]! {void} at: index {IntegerVar} store: ptr {Heaper} | loc {Int32} tmp {Heaper wimpy} | loc := self hashFind: index. ((tmp _ myPtrs fetch: loc) ~~ NULL and: [tmp ~~ PrimRemovedObject make]) ifFalse: [myTally := myTally + 1]. myIndices at: loc storeIntegerVar: index. myPtrs at: loc store: ptr. myTally > (2 * myPtrs count / 3) ifTrue: [ self grow ]! {void} clearAll "Clear all entries from the table. I know this looks like a hack, but the alternative is to throw away the table and build a new one: an expensive prospect for comm." myPtrs storeAll. myTally _ Int32Zero! {Int32 INLINE} count ^myTally! {Heaper | NULL} fetch: index {IntegerVar} | loc {Int32} tmp {Heaper wimpy} | loc _ self hashFind: index. tmp _ myPtrs fetch: loc. (tmp == NULL or: [tmp == PrimRemovedObject make]) ifTrue: [ ^NULL ]. ^ tmp! {Heaper} get: index {IntegerVar} | loc {Int32} tmp {Heaper wimpy} | loc _ self hashFind: index. tmp _ myPtrs fetch: loc. (tmp == NULL or: [tmp == PrimRemovedObject make]) ifTrue: [ Heaper BLAST: #NotInTable ]. ^ tmp! {void} remove: index {IntegerVar} | loc {Int32} | loc := self hashFind: index. ((myPtrs fetch: loc) == NULL or: [(myPtrs fetch: loc) == PrimRemovedObject make]) ifTrue: [ Heaper BLAST: #NotInTable ]. myPtrs at: loc store: PrimRemovedObject make. myTally := myTally - 1.! {void} wipe: index {IntegerVar} | loc {Int32} | loc := self hashFind: index. ((myPtrs fetch: loc) == NULL or: [(myPtrs fetch: loc) == PrimRemovedObject make]) ifTrue: [ ^ VOID ]. myPtrs at: loc store: PrimRemovedObject make. myTally := myTally - 1.! ! !PrimPtrTable methodsFor: 'protected: destruct'! {void} destruct myPtrs destroy. myIndices destroy. super destruct! ! !PrimPtrTable methodsFor: 'private:'! {void} grow | oldPtrs {PtrArray} oldIndices {IntegerVarArray} newIndices {IntegerVarArray} tmp {Heaper wimpy} removed {Heaper wimpy} | oldPtrs := myPtrs. oldIndices := myIndices. "To be GC safe, instance variables are not modified until all allocations are complete." newIndices := IntegerVarArray zeros: 5 * myPtrs count // 3. myExecutor == NULL ifTrue: [myPtrs := PtrArray nulls: newIndices count] ifFalse: [myPtrs := WeakPtrArray make: myExecutor with: newIndices count]. myIndices := newIndices. removed _ PrimRemovedObject make. Int32Zero almostTo: oldPtrs count do: [:i {UInt32} | | loc {Int32} | ((tmp _ oldPtrs fetch: i) ~~ NULL and: [tmp ~~ removed]) ifTrue: [loc := self hashFind: (oldIndices integerVarAt: i). myIndices at: loc storeIntegerVar: (oldIndices integerVarAt: i). myPtrs at: loc store: (oldPtrs fetch: i)]]. oldPtrs destroy. oldIndices destroy! {Int32} hashFind: value {IntegerVar} | loc {Int32}firstRemoved {Int32} tmp {Heaper wimpy} removed {Heaper wimpy} looped {BooleanVar} | firstRemoved _ -1. value == nil ifFalse: [ loc := (FHash fastHash.UInt32: value DOTasLong) \\ myPtrs count. removed _ PrimRemovedObject make]. looped _ false. [(tmp _ myPtrs fetch: loc) ~~ NULL] whileTrue: [(myIndices integerVarAt: loc) == value ifTrue: [ ^ loc ]. tmp == removed ifTrue: [firstRemoved == -1 ifTrue: [firstRemoved _ loc]]. loc := loc + 1. loc >= myPtrs count ifTrue: [looped ifTrue: [^firstRemoved] ifFalse: [looped _ true]. loc := Int32Zero]]. firstRemoved ~~ -1 ifTrue: [ ^ firstRemoved ] ifFalse: [ ^ loc ]! ! !PrimPtrTable methodsFor: 'protected: create'! create: size {Int32} super create. myPtrs := PtrArray nulls: size. myIndices := IntegerVarArray zeros: size. myTally := Int32Zero. myExecutor := NULL! create: size {Int32} with: executor {XnExecutor | NULL} super create. "Create weak array last to be GC safe" myIndices := IntegerVarArray zeros: size. myTally := Int32Zero. myExecutor := PrimPtrTableExecutor make: self with: executor. myPtrs := WeakPtrArray make: myExecutor with: size.! ! !PrimPtrTable methodsFor: 'enumerating'! {PrimPtrTableStepper} stepper ^ PrimPtrTableStepper create: myIndices with: myPtrs with: Int32Zero! ! !PrimPtrTable methodsFor: 'private: weakness'! {void} weakRemove: index {Int32} with: follower {XnExecutor | NULL} "By way of a weird kluge, this passes the index that the item was stored at in this table to the follow up executor" | virtualIndex {Int32} | myPtrs at: index store: PrimRemovedObject make. virtualIndex := (myIndices integerAt: index) DOTasLong. myTally := myTally - 1. follower ~~ NULL ifTrue: [follower execute: virtualIndex].! ! !PrimPtrTable methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PrimPtrTable class instanceVariableNames: ''! (PrimPtrTable getOrMakeCxxClassDescription) friends: '/* friends for class PrimPtrTable */ friend class PrimPtrTableExecutor;'; attributes: ((Set new) add: #CONCRETE; yourself)! !PrimPtrTable class methodsFor: 'smalltalk: defaults'! {PrimPtrTable} weak: size {Int32} ^ self create: size with: NULL! ! !PrimPtrTable class methodsFor: 'create'! make: size {Int32} ^ self create: size! {PrimPtrTable} weak: size {Int32} with: executor {XnExecutor default: NULL} ^ self create: size with: executor! !XnExecutor subclass: #PrimPtrTableExecutor instanceVariableNames: ' myTable {PrimPtrTable} myFollower {XnExecutor | NULL}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-primtab'! (PrimPtrTableExecutor getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !PrimPtrTableExecutor methodsFor: 'invoking'! {void} execute: estateIndex {Int32} myTable weakRemove: estateIndex with: myFollower! ! !PrimPtrTableExecutor methodsFor: 'protected: create'! create: table {PrimPtrTable} with: follower {XnExecutor | NULL} super create. myTable := table. myFollower := follower.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PrimPtrTableExecutor class instanceVariableNames: ''! (PrimPtrTableExecutor getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !PrimPtrTableExecutor class methodsFor: 'create'! make: table {PrimPtrTable} with: follower {XnExecutor | NULL} ^ self create: table with: follower! !Heaper subclass: #PrimRemovedObject instanceVariableNames: '' classVariableNames: 'TheRemovedObject {Heaper} ' poolDictionaries: '' category: 'Xanadu-primtab'! PrimRemovedObject comment: 'A single instance of this exists as a marker for slots in PrimTables where entries have been removed. This object lives on the GC heap to keep weak arrays happy'! (PrimRemovedObject getOrMakeCxxClassDescription) attributes: ((Set new) add: #EQ; add: #NO.GC; add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !PrimRemovedObject methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PrimRemovedObject class instanceVariableNames: ''! (PrimRemovedObject getOrMakeCxxClassDescription) attributes: ((Set new) add: #EQ; add: #NO.GC; add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !PrimRemovedObject class methodsFor: 'accessing'! {Heaper wimpy INLINE} make ^ TheRemovedObject! ! !PrimRemovedObject class methodsFor: 'smalltalk: init'! initTimeNonInherited TheRemovedObject _ PrimRemovedObject create.! linkTimeNonInherited TheRemovedObject _ NULL! !Heaper subclass: #PrimSet instanceVariableNames: ' myPtrs {PtrArray} myTally {Int4} myWeakness {BooleanVar} myExecutor {XnExecutor | NULL}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-primtab'! PrimSet comment: 'A set of pointers. May be strong or weak. If we have a separate executor, it is called with the remaining size after removal.'! (PrimSet getOrMakeCxxClassDescription) friends: '/* friends for class PrimSet */ friend class PrimSetExecutor;'; attributes: ((Set new) add: #CONCRETE; yourself)! !PrimSet methodsFor: 'enumerating'! {Stepper} stepper ^ PrimSetStepper make: myPtrs! ! !PrimSet methodsFor: 'adding-removing'! {void} introduce: value {Heaper} | loc {Int32} | loc := self hashFind: value. loc == -1 ifTrue: [ self hack. self grow. loc := self hashFind: value]. (myPtrs fetch: loc) == value ifTrue: [ Heaper BLAST: #AlreadyInSet ] ifFalse: [ myPtrs at: loc store: value. myTally := myTally + 1. myTally > (2 * myPtrs count / 3) ifTrue: [ self grow ]]! {void} remove: value {Heaper} | loc {Int32} | loc := self hashFind: value. (myPtrs fetch: loc) ~~ value ifTrue: [ Heaper BLAST: #NotInSet ]. myPtrs at: loc store: PrimRemovedObject make. myTally := myTally - 1.! {void} store: value {Heaper} | loc {Int32} | loc := self hashFind: value. loc == -1 ifTrue: [ self hack. self grow. loc := self hashFind: value]. (myPtrs fetch: loc) ~= value ifTrue: [ myPtrs at: loc store: value. myTally := myTally + 1. myTally > (2 * myPtrs count / 3) ifTrue: [ self grow ]]! {void} wipe: value {Heaper} | loc {Int32} | loc := self hashFind: value. (myPtrs fetch: loc) == value ifTrue: [ myPtrs at: loc store: PrimRemovedObject make. myTally := myTally - 1].! {void} wipeAll myPtrs storeAll. myTally := Int32Zero.! ! !PrimSet methodsFor: 'accessing'! {Int32 INLINE} count ^myTally! {BooleanVar} hasMember: element {Heaper} | tmp {Heaper wimpy} | tmp _ myPtrs fetch: (self hashFind: element). ^ tmp == element! {BooleanVar} isEmpty ^myTally == Int32Zero! ! !PrimSet methodsFor: 'private:'! {void} grow | oldPtrs {PtrArray} removed {Heaper wimpy} | oldPtrs := myPtrs. myWeakness ifTrue: [myPtrs := WeakPtrArray make: (PrimSetExecutor make: self) with: 5 * oldPtrs count // 3] ifFalse: [myPtrs := PtrArray nulls: 5 * oldPtrs count // 3]. removed := PrimRemovedObject make. Int32Zero almostTo: oldPtrs count do: [:i {Int32} | | tmp {Heaper wimpy} | tmp := oldPtrs fetch: i. (tmp ~~ NULL and: [tmp ~~ removed]) ifTrue: [|loc {Int32} | loc := self hashFind: tmp. myPtrs at: loc store: tmp]]. oldPtrs destroy! {Int32} hashFind: value {Heaper} | loc {Int32} firstRemoved {Int32} tmp {Heaper wimpy} removed {Heaper wimpy} looped {BooleanVar} | firstRemoved _ -1. loc := value hashForEqual. loc := (FHash fastHash.UInt32: loc) \\ myPtrs count. removed _ PrimRemovedObject make. looped _ false. [(tmp _ myPtrs fetch: loc) ~~ NULL] whileTrue: [tmp == value ifTrue: [ ^ loc ]. tmp == removed ifTrue: [firstRemoved == -1 ifTrue: [firstRemoved _ loc]]. loc := loc + 1. loc >= myPtrs count ifTrue: [looped ifTrue: [^firstRemoved] ifFalse: [looped _ true]. loc := Int32Zero]]. firstRemoved ~~ -1 ifTrue: [ ^ firstRemoved ] ifFalse: [ ^ loc ]! ! !PrimSet methodsFor: 'protected: create'! create: size {Int32} with.Executor: exec {XnExecutor} super create. myWeakness := true. myExecutor := exec. myPtrs := WeakPtrArray make: (PrimSetExecutor make: self) with: size. myTally := Int32Zero.! create: size {Int32} with: weakness {BooleanVar} super create. myWeakness := weakness. myExecutor := NULL. weakness ifTrue: [myPtrs := WeakPtrArray make: (PrimSetExecutor make: self) with: size] ifFalse: [myPtrs := PtrArray nulls: size]. myTally := Int32Zero.! ! !PrimSet methodsFor: 'private: weakness'! {void} weakRemove: index {Int32} myPtrs at: index store: PrimRemovedObject make. "NULL will mess up hashFind" myTally := myTally - 1. myExecutor ~~ NULL ifTrue: [ myExecutor execute: myTally].! ! !PrimSet methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PrimSet class instanceVariableNames: ''! (PrimSet getOrMakeCxxClassDescription) friends: '/* friends for class PrimSet */ friend class PrimSetExecutor;'; attributes: ((Set new) add: #CONCRETE; yourself)! !PrimSet class methodsFor: 'create'! make ^ self create: 7 with: false! make: size {Int32} ^ self create: size with: false! {PrimSet} weak ^ self create: 7 with: true! {PrimSet} weak: size {Int32} ^ self create: size with: true! {PrimSet} weak: size {Int32} with: exec {XnExecutor} ^ self create: size with.Executor: exec! ! !PrimSet class methodsFor: 'smalltalk: create'! create: size {Int32} with.Executor: exec {XnExecutor} ^self new create: size with.Executor: exec! !XnExecutor subclass: #PrimSetExecutor instanceVariableNames: 'mySet {PrimSet}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-primtab'! (PrimSetExecutor getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !PrimSetExecutor methodsFor: 'protected: create'! create: set {PrimSet} super create. mySet := set! ! !PrimSetExecutor methodsFor: 'execution'! {void} execute: estateIndex {Int32} mySet weakRemove: estateIndex! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PrimSetExecutor class instanceVariableNames: ''! (PrimSetExecutor getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !PrimSetExecutor class methodsFor: 'pseudoconstructor'! make: set {PrimSet} ^ self create: set! !Heaper subclass: #PrimSpec instanceVariableNames: 'myClass {Category}' classVariableNames: ' TheIEEE32Spec {PrimFloatSpec} TheIEEE64Spec {PrimFloatSpec} TheInt32Spec {PrimIntegerSpec} TheIntegerVarSpec {PrimIntegerSpec} ThePtrSpec {PrimPointerSpec} TheSharedPtrSpec {PrimPointerSpec} TheUInt32Spec {PrimIntegerSpec} TheUInt8Spec {PrimIntegerSpec} ' poolDictionaries: '' category: 'X++ PrimArrays'! PrimSpec comment: 'A specification of a kind of primitive data type which can be stored in PrimArrays. It gives you protocol for creating and copying PrimArrays. The class and characteristics of this object determine what kind of things are stored there, and how much precision they have.'! (PrimSpec getOrMakeCxxClassDescription) attributes: ((Set new) add: #(COPY xpp ); add: #DEFERRED; yourself)! !PrimSpec methodsFor: 'private: making'! {PrimArray} privateCopy: array {PrimArray} with: size {Int32 default: -1} with: start {Int32 default: Int32Zero} with: count {Int32 default: -1} with: offset {Int32 default: Int32Zero} "Support for copy:with:with:with:with:" self subclassResponsibility.! ! !PrimSpec methodsFor: 'smalltalk: defaults'! {PrimArray} array ^self array: 0! {PrimArray} copy: array {PrimArray} ^self copy: array with: -1 with: 0 with: 0 with: 0! {PrimArray} copy: array {PrimArray} with: count {Int32 default: -1} ^self copy: array with: count with: 0 with: 0 with: 0! {PrimArray} copy: array {PrimArray} with: count {Int32 default: -1} with: start {Int32 default: Int32Zero} ^self copy: array with: count with: start with: 0 with: 0! {PrimArray} copy: array {PrimArray} with: count {Int32 default: -1} with: start {Int32 default: Int32Zero} with: before {Int32 default: Int32Zero} ^self copy: array with: count with: start with: before with: 0! ! !PrimSpec methodsFor: 'protected:'! {Category INLINE} arrayClass ^myClass! ! !PrimSpec methodsFor: 'protected: create'! create: primClass {Category} super create. myClass _ primClass.! ! !PrimSpec methodsFor: 'making'! {PrimArray} array: count {Int32 default: Int32Zero} "Make an array initialized to some reasonable zero value" self subclassResponsibility! {PrimArray} arrayFromBuffer: count {Int32} with: buffer {void star} "Make an array with the values at the given address" self subclassResponsibility! {PrimArray} arrayWith: value {Heaper} "Make a single element array containing the given value" | result {PrimArray} | result _ self array: 1. result at: Int32Zero storeValue: value. ^result! {PrimArray} arrayWithThree: value {Heaper} with: other {Heaper} with: another {Heaper} "Make a two element array containing the given values" | result {PrimArray} | result _ self array: 3. result at: Int32Zero storeValue: value. result at: 1 storeValue: other. result at: 2 storeValue: another. ^ result! {PrimArray} arrayWithTwo: value {Heaper} with: other {Heaper} "Make a two element array containing the given values" | result {PrimArray} | result _ self array: 2. result at: Int32Zero storeValue: value. result at: 1 storeValue: other. ^ result.! {PrimArray} copy: array {PrimArray} with: count {Int32 default: -1} with: start {Int32 default: Int32Zero} with: before {Int32 default: Int32Zero} with: after {Int32 default: Int32Zero} "Make a copy of an array with a different representation size. The arguments are the same as in PrimArray::copy." | copyCount {Int32} | count < Int32Zero ifTrue: [copyCount _ array count - start] ifFalse: [copyCount _ count. start + copyCount > array count ifTrue: [Heaper BLAST: #IndexOutOfBounds]]. ^self privateCopy: array with: copyCount + before + after with: start with: copyCount with: before! {PrimArray} copyGrow: array {PrimArray} with: after {Int32} "Make a copy of the array into a larger array. The array has 'after' slots after the copied elements." ^self copy: array with: -1 with: Int32Zero with: Int32Zero with: after! ! !PrimSpec methodsFor: 'accessing'! {Int32 CLIENT} sizeofElement "Essential. The size of a single element of the array, to be used to allocated space for copyTo/FromBuffer. In the same units as C sizeof ()." self unimplemented. ^Int32Zero "fodder"! ! !PrimSpec methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! ! !PrimSpec methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myClass _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myClass.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PrimSpec class instanceVariableNames: ''! (PrimSpec getOrMakeCxxClassDescription) attributes: ((Set new) add: #(COPY xpp ); add: #DEFERRED; yourself)! !PrimSpec class methodsFor: 'private: init'! {void} initSpecs "moved from initTime because MS C++/NT does not like large initTimes" TheUInt8Spec := PrimIntegerSpec create: UInt8Array with: 8 with: false. TheUInt32Spec := PrimIntegerSpec create: UInt32Array with: 32 with: false. TheInt32Spec := PrimIntegerSpec create: Int32Array with: 32 with: true. TheIntegerVarSpec := PrimIntegerSpec create: IntegerVarArray with: -1 with: true. TheIEEE32Spec := PrimFloatSpec create: IEEE32Array with: 32. TheIEEE64Spec := PrimFloatSpec create: IEEE64Array with: 64. ThePtrSpec := PrimPointerSpec create: PtrArray. TheSharedPtrSpec := PrimPointerSpec create: SharedPtrArray.! ! !PrimSpec class methodsFor: 'smalltalk: init'! initTimeNonInherited self initSpecs! linkTimeNonInherited TheUInt8Spec := NULL. TheUInt32Spec := NULL. TheInt32Spec := NULL. TheIntegerVarSpec := NULL. TheIEEE32Spec := NULL. TheIEEE64Spec := NULL. ThePtrSpec := NULL. TheSharedPtrSpec := NULL.! ! !PrimSpec class methodsFor: 'pseudo constructors'! {PrimFloatSpec INLINE} iEEE32 ^TheIEEE32Spec! {PrimFloatSpec INLINE} iEEE64 ^TheIEEE64Spec! {PrimFloatSpec} iEEE: precision {Int32} precision = 32 ifTrue: [^TheIEEE32Spec]. precision = 64 ifTrue: [^TheIEEE64Spec]. self unimplemented. ^NULL! {PrimIntegerSpec INLINE} int32 ^TheInt32Spec! {PrimIntegerSpec INLINE} integerVar ^TheIntegerVarSpec! {PrimPointerSpec INLINE} pointer "A spec for pointers to object" ^ThePtrSpec! {PrimPointerSpec INLINE} sharedPointer ^TheSharedPtrSpec! {PrimIntegerSpec} signedInteger: bitCount {Int32} bitCount = 32 ifTrue: [^TheInt32Spec]. self unimplemented. ^NULL! {PrimIntegerSpec} toHold: value {IntegerVar} "The least demanding spec that will hold the given value" value < IntegerVar0 ifTrue: [value < Int32Min ifTrue: [^self integerVar] ifFalse: [^self int32]] ifFalse: [value <= Int32Max ifTrue: [value <= UInt8Max ifTrue: [^self uInt8] ifFalse: [^self int32]] ifFalse: [value <= UInt32Max ifTrue: [^self uInt32] ifFalse: [^self integerVar]]]! {PrimIntegerSpec INLINE} uInt32 ^TheUInt32Spec! {PrimIntegerSpec INLINE} uInt8 ^TheUInt8Spec! {PrimIntegerSpec} unsignedInteger: bitCount {Int32} bitCount = 32 ifTrue: [^TheUInt32Spec]. bitCount = 8 ifTrue: [^TheUInt8Spec]. self unimplemented. ^NULL! ! !PrimSpec class methodsFor: 'smalltalk: system'! info.stProtocol "{PrimArray CLIENT} arrayFromBuffer: count {Int32} with: buffer {void star} {PrimArray CLIENT} arrayWith: value {Heaper} {PrimArray CLIENT} arrayWithThree: value {Heaper} with: other {Heaper} with: another {Heaper} {PrimArray CLIENT} arrayWithTwo: value {Heaper} with: other {Heaper} {Int32 CLIENT} sizeofElement "! !PrimSpec subclass: #PrimFloatSpec instanceVariableNames: 'myBitCount {Int32}' classVariableNames: '' poolDictionaries: '' category: 'X++ PrimArrays'! PrimFloatSpec comment: 'Specifies different precisions and representations of floating point numbers.'! (PrimFloatSpec getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY xpp ); yourself)! !PrimFloatSpec methodsFor: 'accessing'! {Int32 INLINE} bitCount "How many total bits per value" ^myBitCount! ! !PrimFloatSpec methodsFor: 'create'! create: primClass {Category} with: bitCount {Int32} super create: primClass. myBitCount := bitCount.! ! !PrimFloatSpec methodsFor: 'testing'! {UInt32} actualHashForEqual ^self getCategory hashForEqual bitXor: (FHash fastHash.UInt32: myBitCount)! {BooleanVar} isEqual: other {Heaper} other cast: PrimFloatSpec into: [ :spec | ^myBitCount = spec bitCount] others: [^false]. ^ false "compiler fodder"! ! !PrimFloatSpec methodsFor: 'private: making'! {PrimArray} privateCopy: array {PrimArray} with: size {Int32 default: -1} with: start {Int32 default: Int32Zero} with: count {Int32 default: -1} with: offset {Int32 default: Int32Zero} "Make a copy of an array with a different representation size. The arguments are the same as in PrimArray::copy." [Eric thingToDo. "Add case for generic floating point--essentially PtrArray of PrimFloat" self == (PrimSpec iEEE64 basicCast: Heaper star) ifTrue: [^IEEE64Array make: size with: array with: start with: count with: offset]. self == (PrimSpec iEEE32 basicCast: Heaper star) ifTrue: [^IEEE32Array make: size with: array with: start with: count with: offset]. Heaper BLAST: #BadPrimSpec] translateOnly. [^myClass create: size with: start with: count with: offset] smalltalkOnly. ^ NULL "compiler fodder"! ! !PrimFloatSpec methodsFor: 'making'! {PrimArray} array: count {Int32 default: Int32Zero} "Make an array initialized to zero values" [Eric thingToDo. "Add case for generic floating point--essentially PtrArray of PrimFloat" self == (PrimSpec iEEE64 basicCast: Heaper star) ifTrue: [^IEEE64Array make: count]. self == (PrimSpec iEEE32 basicCast: Heaper star) ifTrue: [^IEEE32Array make: count]. Heaper BLAST: #BadPrimSpec] translateOnly. [^myClass create: count] smalltalkOnly. ^ NULL "compiler fodder"! {PrimArray} arrayFromBuffer: count {Int32} with: buffer {void star} "Make an array with the values at the given address" ["Generic case of unspecified size can't be handled here." self == (PrimSpec iEEE64 basicCast: Heaper star) ifTrue: [^IEEE64Array make: count with: buffer]. self == (PrimSpec iEEE32 basicCast: Heaper star) ifTrue: [^IEEE32Array make: count with: buffer]. Heaper BLAST: #BadPrimSpec] translateOnly. [^myClass create: count with: buffer] smalltalkOnly. ^ NULL "compiler fodder"! {PrimFloatValue} preciseValue: number {IEEE128} "A boxed floating point value from a large precision number" "myBitCount = 32 ifTrue: [^PrimIEEE32 make: self with: number]. myBitCount = 64 ifTrue: [^PrimIEEE64 make: self with: number]" self unimplemented. ^NULL "fodder"! {PrimFloatValue} value: number {IEEE64} "A boxed floating point value" myBitCount = 32 ifTrue: [^PrimIEEE32 make: number]. myBitCount = 64 ifTrue: [^PrimIEEE64 make: number]. ^NULL "fodder"! ! !PrimFloatSpec methodsFor: 'smalltalk: passe'! {Int32} precision self passe "bitCount"! ! !PrimFloatSpec methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myBitCount _ receiver receiveInt32.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendInt32: myBitCount.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PrimFloatSpec class instanceVariableNames: ''! (PrimFloatSpec getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY xpp ); yourself)! !PrimFloatSpec class methodsFor: 'smalltalk: system'! info.stProtocol "{PrimFloat CLIENT} preciseValue: number {IEEE128} {Int32 CLIENT} precision {PrimFloat CLIENT} value: number {IEEE64} "! !PrimSpec subclass: #PrimIntegerSpec instanceVariableNames: ' myBitCount {Int32} amSigned {BooleanVar} myMin {Int32} myMax {Int32}' classVariableNames: '' poolDictionaries: '' category: 'X++ PrimArrays'! (PrimIntegerSpec getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY xpp ); yourself)! !PrimIntegerSpec methodsFor: 'accessing'! {Int32 INLINE} bitCount "How many bits, or zero if it is unlimited" ^myBitCount! {PrimIntegerSpec} combine: other {PrimIntegerSpec} "A spec whose range of values contains both ranges" self == other ifTrue: [^self]. myBitCount == Int32Zero ifTrue: [^self]. other bitCount == Int32Zero ifTrue: [^other]. myBitCount < other bitCount ifTrue: [^other]. myBitCount > other bitCount ifTrue: [^self]. amSigned == other isSigned ifTrue: [^self]. "here we get ad hoc since we need to expand to the next larger size" myBitCount == 8 ifTrue: [^PrimSpec int32]. ^PrimSpec integerVar! {BooleanVar INLINE} isSigned "Whether it allows negative values" ^amSigned! ! !PrimIntegerSpec methodsFor: 'create'! create: primClass {Category} with: bitCount {Int32} with: isSigned {BooleanVar} super create: primClass. myBitCount := bitCount. amSigned := isSigned. myBitCount ~~ -1 ifTrue: [amSigned ifTrue: [[myMin := (2 raisedTo: myBitCount - 1) negated. myMax := myMin negated - 1] smalltalkOnly. 'myMin = 1 << (myBitCount - 1); myMax = ~myMin;' translateOnly] ifFalse: [[myMin := Int32Zero. myMax := (2 raisedTo: myBitCount) - 1] smalltalkOnly. 'myMin = Int32Zero; /* the shift is done in two steps to avoid five-bit truncation on SPARCs */ myMax = ~(((~Int32Zero) << (myBitCount - 1)) << 1);' translateOnly]]! ! !PrimIntegerSpec methodsFor: 'testing'! {UInt32} actualHashForEqual | signPart {UInt32} | amSigned ifTrue: [signPart _ 255] ifFalse: [signPart _ UInt32Zero]. ^(self getCategory hashForEqual bitXor: (FHash fastHash.UInt32: myBitCount)) bitXor: signPart! {BooleanVar} canHold: value {IntegerVar} "Whether this spec can hold the given value" [^myBitCount = -1 or: [value >= myMin and: [value <= myMax]]] smalltalkOnly. 'if (myBitCount = -1) { return TRUE; } else if (amSigned) { return value >= myMin && value <= myMax; } else { return (unsigned) value.asLong () >= (unsigned) myMin && (unsigned) value.asLong () <= (unsigned) myMax; }' translateOnly! {BooleanVar} isEqual: other {Heaper} other cast: PrimIntegerSpec into: [ :spec | ^myBitCount = spec bitCount and: [amSigned == spec isSigned]] others: [^false]. ^ false "compiler fodder"! ! !PrimIntegerSpec methodsFor: 'making'! {PrimArray} array: count {Int32 default: Int32Zero} "Make an array initialized to zero values" [self == (PrimSpec uInt32 basicCast: Heaper star) ifTrue: [^UInt32Array make: count]. self == (PrimSpec uInt8 basicCast: Heaper star) ifTrue: [^UInt8Array make: count]. self == (PrimSpec int32 basicCast: Heaper star) ifTrue: [^Int32Array make: count]. self == (PrimSpec integerVar basicCast: Heaper star) ifTrue: [^IntegerVarArray zeros: count]. Heaper BLAST: #BadPrimSpec] translateOnly. [^myClass create: count] smalltalkOnly. ^ NULL "compiler fodder"! {PrimArray} arrayFromBuffer: count {Int32} with: buffer {void star} "Make an array with the values at the given address" [self == (PrimSpec uInt32 basicCast: Heaper star) ifTrue: [^UInt32Array make: count with: buffer]. self == (PrimSpec uInt8 basicCast: Heaper star) ifTrue: [^UInt8Array make: count with: buffer]. self == (PrimSpec int32 basicCast: Heaper star) ifTrue: [^Int32Array make: count with: buffer]. self == (PrimSpec integerVar basicCast: Heaper star) ifTrue: [^IntegerVarArray make: count with: buffer]. Heaper BLAST: #BadPrimSpec] translateOnly. [^myClass create: count with: buffer] smalltalkOnly. ^ NULL "compiler fodder"! {PrimIntegerArray} string: string {char star} "Make an array the contents of the string" self == (PrimSpec uInt8 basicCast: Heaper star) ifTrue: [^UInt8Array string: string]. self unimplemented. ^NULL "fodder"! {PrimIntValue INLINE} value: number {IntegerVar} "A boxed integer value" ^PrimIntValue make: number! ! !PrimIntegerSpec methodsFor: 'private: making'! {PrimArray} privateCopy: array {PrimArray} with: size {Int32 default: -1} with: start {Int32 default: Int32Zero} with: count {Int32 default: -1} with: offset {Int32 default: Int32Zero} "Make a copy of an array with a different representation size. The arguments are the same as in PrimArray::copy." [self == (PrimSpec uInt32 basicCast: Heaper star) ifTrue: [^UInt32Array make: size with: array with: start with: count with: offset]. self == (PrimSpec uInt8 basicCast: Heaper star) ifTrue: [^UInt8Array make: size with: array with: start with: count with: offset]. self == (PrimSpec int32 basicCast: Heaper star) ifTrue: [^Int32Array make: size with: array with: start with: count with: offset]. self == (PrimSpec integerVar basicCast: Heaper star) ifTrue: [^IntegerVarArray make: size with: array with: start with: count with: offset]. Heaper BLAST: #BadPrimSpec] translateOnly. [^myClass create: size with: array with: start with: count with: offset] smalltalkOnly. ^ NULL "compiler fodder"! ! !PrimIntegerSpec methodsFor: 'smalltalk: passe'! {Int32} precision self passe "bitCount"! ! !PrimIntegerSpec methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myBitCount _ receiver receiveInt32. amSigned _ receiver receiveBooleanVar. myMin _ receiver receiveInt32. myMax _ receiver receiveInt32.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendInt32: myBitCount. xmtr sendBooleanVar: amSigned. xmtr sendInt32: myMin. xmtr sendInt32: myMax.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PrimIntegerSpec class instanceVariableNames: ''! (PrimIntegerSpec getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY xpp ); yourself)! !PrimIntegerSpec class methodsFor: 'smalltalk: system'! info.stProtocol "{BooleanVar CLIENT} isSigned {Int32 CLIENT} precision {PrimIntegerArray CLIENT} string: string {char star} {PrimInteger CLIENT} value: number {IntegerVar} "! !PrimSpec subclass: #PrimPointerSpec instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'X++ PrimArrays'! PrimPointerSpec comment: 'Describes a kind of primitive pointer array'! (PrimPointerSpec getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY xpp ); yourself)! !PrimPointerSpec methodsFor: 'testing'! {UInt32} actualHashForEqual ^self getCategory hashForEqual bitXor: self arrayClass hashForEqual! {BooleanVar} isEqual: other {Heaper} ^(other isKindOf: PrimPointerSpec) and: [self arrayClass == (other cast: PrimPointerSpec) arrayClass]! ! !PrimPointerSpec methodsFor: 'private: making'! {PrimArray} privateCopy: array {PrimArray} with: size {Int32 default: -1} with: start {Int32 default: Int32Zero} with: count {Int32 default: -1} with: offset {Int32 default: Int32Zero} "Make a copy of an array with a different representation size. The arguments are the same as in PrimArray::copy." [self == (PrimSpec pointer basicCast: Heaper star) ifTrue: [^PtrArray make: size with: array with: start with: count with: offset]. self == (PrimSpec sharedPointer basicCast: Heaper star) ifTrue: [^SharedPtrArray make: size with: array with: start with: count with: offset]. Heaper BLAST: #BadPrimSpec] translateOnly. [^myClass create: size with: start with: count with: offset] smalltalkOnly. ^ NULL "compiler fodder"! ! !PrimPointerSpec methodsFor: 'create'! create: primClass {Category} super create: primClass.! ! !PrimPointerSpec methodsFor: 'making'! {PrimArray} array: count {Int32 default: Int32Zero} "Make an array initialized to null values" [self == (PrimSpec pointer basicCast: Heaper star) ifTrue: [^PtrArray nulls: count]. self == (PrimSpec sharedPointer basicCast: Heaper star) ifTrue: [^SharedPtrArray make: count]. Heaper BLAST: #BadPrimSpec] translateOnly. [^myClass create: count] smalltalkOnly. ^ NULL "compiler fodder"! {PrimArray} arrayFromBuffer: count {Int32} with: buffer {void star} "Make an array with the values at the given address" [self == (PrimSpec pointer basicCast: Heaper star) ifTrue: [^PtrArray make: count with: buffer]. self == (PrimSpec sharedPointer basicCast: Heaper star) ifTrue: [^SharedPtrArray make: count with: buffer]. Heaper BLAST: #BadPrimSpec] translateOnly. [^myClass create: count with: buffer] smalltalkOnly. ^ NULL "compiler fodder"! ! !PrimPointerSpec methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !Heaper subclass: #PrimValue instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'X++ PrimArrays'! PrimValue comment: 'A boxed representation of a primitive data type'! (PrimValue getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; yourself)! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PrimValue class instanceVariableNames: ''! (PrimValue getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; yourself)! !PrimValue class methodsFor: 'smalltalk: system'! info.stProtocol "{PrimSpec CLIENT} spec "! !PrimValue subclass: #PrimFloatValue instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'X++ PrimArrays'! PrimFloatValue comment: 'A boxed representation of a floating point value'! (PrimFloatValue getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; add: #(COPY xpp ); yourself)! !PrimFloatValue methodsFor: 'smalltalk: accessing'! {IEEE128} asIEEE128 "The value as an IEEE 128-bit floating point number. May not be possible if conversion from subclass to IEEE type is not available." self subclassResponsibility! ! !PrimFloatValue methodsFor: 'accessing'! {IEEE32} asIEEE32 "The value as an IEEE 32-bit floating point number. May not be possible if conversion from subclass to IEEE type is not available." self subclassResponsibility! {IEEE64} asIEEE64 "The value as an IEEE 64-bit floating point number. May not be possible if conversion from subclass to IEEE type is not available." self subclassResponsibility! {Int32 CLIENT} bitCount "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." self subclassResponsibility! {IntegerVar} exponent "If this is a number, return the exponent" self subclassResponsibility! {BooleanVar} isANumber "Return TRUE if value represents a number." self subclassResponsibility! {IntegerVar} mantissa "If this is a number, return the signed mantissa" self subclassResponsibility! ! !PrimFloatValue methodsFor: 'smalltalk: passe'! {BooleanVar} isNumber self passe! {Int32} precision self passe "bitCount"! ! !PrimFloatValue methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PrimFloatValue class instanceVariableNames: ''! (PrimFloatValue getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; add: #(COPY xpp ); yourself)! !PrimFloatValue class methodsFor: 'smalltalk: system'! info.stProtocol "{IEEE128 CLIENT} asIEEE128 {IEEE128 CLIENT} asIEEE128Approximation {IEEE32 CLIENT} asIEEE32 {IEEE32 CLIENT} asIEEE32Approximation {IEEE64 CLIENT} asIEEE64 {IEEE64 CLIENT} asIEEE64Approximation {IntegerVar CLIENT} exponent {BooleanVar CLIENT} isANumber {IntegerVar CLIENT} mantissa {Int32 CLIENT} precision "! !PrimFloatValue subclass: #PrimIEEE32 instanceVariableNames: 'myValue {IEEE32}' classVariableNames: '' poolDictionaries: '' category: 'X++ PrimArrays'! PrimIEEE32 comment: 'A boxed representation of an IEEE 32-bit floating point value'! (PrimIEEE32 getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY xpp ); yourself)! !PrimIEEE32 methodsFor: 'testing'! {UInt32} actualHashForEqual Eric thingToDo. "Figure out a hash for floats" [^myValue hash] smalltalkOnly. [Eric shouldImplement. ^ self bitCount] translateOnly.! {BooleanVar} isEqual: other {Heaper} (other isKindOf: PrimIEEE32) ifFalse: [Heaper BLAST: #IncomparableType ]. ^ myValue = (other cast: PrimIEEE32) asIEEE32! ! !PrimIEEE32 methodsFor: 'smalltalk: accessing'! {IEEE128} asIEEE128 self unimplemented. 'IEEE128 a; return a; /* fodder */' translateOnly! ! !PrimIEEE32 methodsFor: 'accessing'! {IEEE32} asIEEE32 "The value as an IEEE 32-bit floating point number" ^ myValue! {IEEE64} asIEEE64 "The value as an IEEE 64-bit floating point number" [^ myValue basicCast: IEEE64] translateOnly. [^ myValue asDouble] smalltalkOnly.! {Int32} bitCount ^32! {IntegerVar} exponent "If this is a number, return the exponent" self isANumber ifFalse: [Heaper BLAST: #NotANumber]. [^ myValue exponent] smalltalkOnly. ' #if defined(_MSC_VER) || defined(HIGHC) || defined(__sgi) || defined (GNUSUN) BLAST(NOT_YET_IMPLEMENTED); return IntegerVarZero; /* fodder */ #else return myValue == 0 ? 0 : ilogb(myValue); #endif /* WIN32 */ ' translateOnly.! {BooleanVar} isANumber [^ myValue isKindOf: Float] smalltalkOnly. ' #if defined(_MSC_VER) || defined(HIGHC) || defined(__sgi)|| defined (GNUSUN) BLAST(NOT_YET_IMPLEMENTED); return FALSE; /* fodder */ #else return finite(myValue); #endif /* WIN32 */ ' translateOnly.! {IntegerVar} mantissa self unimplemented. ^IntegerVarZero "fodder"! ! !PrimIEEE32 methodsFor: 'protected: create'! create: value {IEEE32} super create. myValue := value.! ! !PrimIEEE32 methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myValue _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myValue.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PrimIEEE32 class instanceVariableNames: ''! (PrimIEEE32 getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY xpp ); yourself)! !PrimIEEE32 class methodsFor: 'create'! make: value {IEEE32} ^ self create: value! !PrimFloatValue subclass: #PrimIEEE64 instanceVariableNames: 'myValue {IEEE64}' classVariableNames: '' poolDictionaries: '' category: 'X++ PrimArrays'! PrimIEEE64 comment: 'A boxed representation of an IEEE 64-bit floating point value'! (PrimIEEE64 getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY xpp ); yourself)! !PrimIEEE64 methodsFor: 'testing'! {UInt32} actualHashForEqual Eric thingToDo. "Figure out a hash for floats" [^myValue hash] smalltalkOnly. [Eric shouldImplement. ^ self bitCount] translateOnly.! {BooleanVar} isEqual: other {Heaper} (other isKindOf: PrimIEEE64) ifFalse: [Heaper BLAST: #IncomparableType ]. ^ myValue = (other cast: PrimIEEE64) asIEEE64! ! !PrimIEEE64 methodsFor: 'smalltalk: accessing'! {IEEE128} asIEEE128 self unimplemented. 'IEEE128 a; return a; /* fodder */' translateOnly! ! !PrimIEEE64 methodsFor: 'accessing'! {IEEE32} asIEEE32 "The value as an IEEE 32-bit floating point number" [^ myValue basicCast: IEEE32] translateOnly. [^ myValue asFloat] smalltalkOnly.! {IEEE64} asIEEE64 "The value as an IEEE 64-bit floating point number" ^ myValue! {Int32} bitCount ^64! {IntegerVar} exponent "If this is a number, return the exponent" self isANumber ifFalse: [Heaper BLAST: #NotANumber]. [^ myValue exponent] smalltalkOnly. ' #if defined(_MSC_VER) || defined(HIGHC) || defined(__sgi) || defined (GNUSUN) BLAST(NOT_YET_IMPLEMENTED); return IntegerVarZero; /* fodder */ #else return myValue == 0 ? 0 : ilogb(myValue); #endif /* WIN32 */ ' translateOnly.! {BooleanVar} isANumber [^ myValue isKindOf: Double] smalltalkOnly. ' #if defined(_MSC_VER) || defined(HIGHC) || defined(__sgi) || defined (GNUSUN) BLAST(NOT_YET_IMPLEMENTED); return FALSE; /* fodder */ #else return finite(myValue); #endif /* WIN32 */ ' translateOnly.! {IntegerVar} mantissa self unimplemented. ^IntegerVarZero "fodder"! ! !PrimIEEE64 methodsFor: 'protected: create'! create: value {IEEE64} super create. myValue := value.! ! !PrimIEEE64 methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myValue _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myValue.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PrimIEEE64 class instanceVariableNames: ''! (PrimIEEE64 getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY xpp ); yourself)! !PrimIEEE64 class methodsFor: 'create'! make: value {IEEE64} ^ self create: value! !PrimValue subclass: #PrimIntValue instanceVariableNames: 'myValue {IntegerVar}' classVariableNames: '' poolDictionaries: '' category: 'X++ PrimArrays'! (PrimIntValue getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #ON.CLIENT; add: #(COPY xpp ); yourself)! !PrimIntValue methodsFor: 'operations'! {IntegerVar CLIENT login} bitwiseAnd: another {PrimIntValue} "Return the the first number bitwise and'd with the second." ^myValue bitAnd: another asIntegerVar! {IntegerVar CLIENT login} bitwiseOr: another {PrimIntValue} "Return the the first number bitwise or'd with the second." ^myValue bitOr: another asIntegerVar! {IntegerVar CLIENT login} bitwiseXor: another {PrimIntValue} "Return the the first number bitwise xor'd with the second." ^myValue bitXor: another asIntegerVar! {IntegerVar CLIENT login} dividedBy: another {PrimIntValue} "Integer divide the two numbers and return the result. This truncates." ^myValue // another asIntegerVar! {BooleanVar CLIENT login} isGE: another {PrimIntValue} "Return true if the first number is greater than or euqla to the second number." ^myValue >= another asIntegerVar! {IntegerVar CLIENT login} leftShift: another {PrimIntValue} "Return the the first number shifted to the left by the second amount." ^myValue bitShift: another asIntegerVar! {IntegerVar CLIENT login} maximum: another {PrimIntValue} "Return the largest of the two numbers." ^myValue max: another asIntegerVar! {IntegerVar CLIENT login} minimum: another {PrimIntValue} "Return the smallest of the two numbers." ^myValue min: another asIntegerVar! {IntegerVar CLIENT login} minus: another {PrimIntValue} "Return the difference two numbers." ^myValue - another asIntegerVar! {IntegerVar CLIENT login} mod: another {PrimIntValue} "Return the the first number modulo the second." ^myValue \\ another asIntegerVar! {IntegerVar CLIENT login} plus: another {PrimIntValue} "Return the sum of two numbers." ^myValue + another asIntegerVar! {IntegerVar CLIENT login} times: another {PrimIntValue} "Multiply the two numbers and return the result." ^myValue * another asIntegerVar! ! !PrimIntValue methodsFor: 'accessing'! {BooleanVar INLINE} asBooleanVar "The value as a BooleanVar." ^myValue ~~ IntegerVarZero! {Int32 INLINE} asInt32 "The value as a 32 bit signed integer" ^myValue DOTasInt32! {IntegerVar INLINE} asIntegerVar "The value as an indefinite precision integer" ^myValue! {UInt32 INLINE} asUInt32 "The value as a 32 bit unsigned integer" ^myValue DOTasUInt32! {UInt8 INLINE} asUInt8 "The value as a 8 bit unsigned integer" ^myValue DOTasUInt32! {Int32 CLIENT} bitCount "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. 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." | precision {Int32} | precision _ (PrimSpec toHold: myValue) bitCount. precision == Int32Zero ifTrue: [Heaper BLAST: #NoBitCountLimit]. ^precision! ! !PrimIntValue methodsFor: 'testing'! {UInt32} actualHashForEqual ^FHash fastHash.UInt32: myValue DOTasLong! {BooleanVar} isEqual: other {Heaper} ^(other isKindOf: PrimIntValue) and: [(other cast: PrimIntValue) asIntegerVar = myValue]! ! !PrimIntValue methodsFor: 'protected: create'! create: value {IntegerVar} super create. myValue := value.! ! !PrimIntValue methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '(' << myValue << ')'! ! !PrimIntValue methodsFor: 'smalltalk: passe'! {Int32} precision self passe "bitCount"! ! !PrimIntValue methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myValue _ receiver receiveIntegerVar.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendIntegerVar: myValue.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PrimIntValue class instanceVariableNames: ''! (PrimIntValue getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #ON.CLIENT; add: #(COPY xpp ); yourself)! !PrimIntValue class methodsFor: 'create'! make: value {IntegerVar} ^ self create: value! ! !PrimIntValue class methodsFor: 'smalltalk: system'! info.stProtocol "{IntegerVar CLIENT} asIntegerVar "! !Heaper subclass: #PromiseManager instanceVariableNames: ' myPortal {Portal} myReadStream {XnReadStream} myWriteStream {XnWriteStream} myActuals {PrimPtrTable} myRefCounts {PrimIndexTable} myDetectorEvents {DetectorEvent} myNextClientPromise {IntegerVar} myNextServerPromise {IntegerVar} myHandlers {PtrArray} myAcks {IntegerVar} myError {ExceptionRecord} amInsideRequest {BooleanVar} myShuffler {ByteShuffler}' classVariableNames: ' AllRequests {PtrArray of: RequestHandler} LoginRequests {PtrArray of: RequestHandler} OverrideArray {Array smalltalk} OverrideMap {Dictionary smalltalk} PromiseClasses {PtrArray of: Category} ' poolDictionaries: '' category: 'Xanadu-proman'! (PromiseManager getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !PromiseManager methodsFor: 'operations'! {void} force self flushAcks. myDetectorEvents ~~ NULL ifTrue: [[myDetectorEvents ~~ NULL] whileTrue: [myDetectorEvents trigger: self. myDetectorEvents _ myDetectorEvents next]]. myWriteStream flush! {void} handleRequest amInsideRequest _ true. self thingToDo. "This should not forward all errors." PromiseManager problems.EVERY.U.COMM handle: [:ex | | prob {Problem} | 'prob = &PROBLEM(ex);' translateOnly. [prob _ Problem create: ex PROBLEM with: ex parameter with: ex initialContext sender printString with: 0] smalltalkOnly. self respondProblem: prob. ex return] do: [| reqnum {Int32} | reqnum _ self receiveRequestNumber. "[cerr cr << myNextClientPromise << (myHandlers get: reqnum). cerr endEntry] smalltalkOnly." ((myHandlers get: reqnum) cast: RequestHandler) handleRequest: self]. myError ~~ NULL ifTrue: [self respondError]. amInsideRequest _ false. myDetectorEvents ~~ NULL "Forcing flushes detector events too." ifTrue: [self force] ifFalse: [myWriteStream flush]! {BooleanVar} noErrors "Return true if no errors have occurred in the current transaction." ^myError == NULL! {void} queueDetectorEvent: event {DetectorEvent} "Queue up the detector event. It will be executed after the next transaction." event setNext: myDetectorEvents. myDetectorEvents _ event. amInsideRequest ifFalse: [self force]! {void} waive "Release the promise argument. This could return a value because the PromiseManager doesn't keep any state for void promises." self actualWaive: self receiveIntegerVar! {void} waiveMany "Release a range of promise argument, given a start and a count. This could return a value because the PromiseManager doesn't keep any state for void promises." | prnum {IntegerVar} prcount {IntegerVar} | prnum _ self receiveIntegerVar. prcount _ self receiveIntegerVar. prnum almostTo: prnum + prcount do: [ :i {IntegerVar} | self actualWaive: i]! ! !PromiseManager methodsFor: 'comm'! {BooleanVar} fetchBooleanVar "Optimize promise arguments that are expected to point at IntValues." | num {IntegerVar} result {Heaper | NULL} | num _ self receiveIntegerVar. result _ myActuals fetch: num. result == NULL ifTrue: [myError _ (ExceptionRecord excuse: num) best: myError. ^false]. result cast: PrimIntValue into: [:number | ^number asIntegerVar ~~ IntegerVarZero] others: [myError _ (ExceptionRecord mismatch: num) best: myError]. ^false! {Category | NULL} fetchCategory | num {Int32} result {Category | NULL} | self thingToDo. "Renumber the categories from 0." num _ self receiveRequestNumber. result _ (PromiseClasses fetch: num) cast: Category. result == NULL ifTrue: [myError _ (ExceptionRecord badCategory: num) best: myError. ^NULL]. ^result! {Heaper} fetchHeaper: cat {Category} | num {IntegerVar} result {Heaper | NULL} | num _ self receiveIntegerVar. num == IntegerVarZero ifTrue: [^NULL]. result _ myActuals fetch: num. result == NULL ifTrue: [myError _ (ExceptionRecord excuse: num) best: myError. ^NULL]. (result isKindOf: cat) ifFalse: [myError _ (ExceptionRecord mismatch: num) best: myError. ^NULL]. ^result! {Int32} fetchInt32 ^self fetchIntegerVar DOTasLong! {IntegerVar} fetchIntegerVar "Optimize promise arguments that are expected to point at IntValues." | num {IntegerVar} result {Heaper | NULL} | num _ self receiveIntegerVar. result _ myActuals fetch: num. result == NULL ifTrue: [myError _ (ExceptionRecord excuse: num) best: myError. ^IntegerVarZero]. result cast: PrimIntValue into: [:number | ^number asIntegerVar] others: [myError _ (ExceptionRecord mismatch: num) best: myError]. ^IntegerVarZero! {Heaper} fetchNonNullHeaper: cat {Category} | num {IntegerVar} result {Heaper | NULL} | num _ self receiveIntegerVar. num == IntegerVarZero ifTrue: [myError _ (ExceptionRecord wasNull: num) best: myError. ^NULL]. result _ myActuals fetch: num. result == NULL ifTrue: [myError _ (ExceptionRecord excuse: num) best: myError. ^NULL]. (result isKindOf: cat) ifFalse: [myError _ (ExceptionRecord mismatch: num) best: myError. ^NULL]. ^result! {IntegerVar} receiveIntegerVar "A new representation that requires less shifting (eventually)." " 7/1 0<7> 14/2 10<6> <8> 21/3 110<5> <16> 28/4 1110<4> <24> 35/5 11110<3> <32> 42/6 111110<2> <40> 49/7 1111110<1> <48> 56/8 11111110 <56> +/+ 11111111 " "This is smalltalk only because smalltalk doesn't do sign-extend." | byte {UInt8} mask {UInt8} count {Int32} num {Int32} | "count is bytes following first word or -1 if bignum meaning next byte is humber for actual count" byte _ myReadStream getByte. byte <= 2r00111111 ifTrue: [^byte]. byte <= 2r01111111 ifTrue: [^byte-128]. byte <= 2r10111111 ifTrue: [mask _ 2r00111111. count _ 1] ifFalse: [byte <= 2r11011111 ifTrue: [mask _ 2r00011111. count _ 2] ifFalse: [byte <= 2r11101111 ifTrue: [mask _ 2r00001111. count _ 3] ifFalse: [byte <= 2r11110111 ifTrue: [mask _ 2r00000111. count _ 4] ifFalse: [self unimplemented]]]]. byte _ byte bitAnd: mask. (byte bitAnd: ((mask bitInvert bitShiftRight: 1) bitAnd: mask)) ~= Int32Zero ifTrue: [byte _ byte bitOr: mask bitInvert. num _ -1] ifFalse: [num _ Int32Zero. ((count > 3) and: [(byte ~= (byte bitAnd: mask))]) ifTrue: [self unimplemented]]. num _ (num bitShift: 8) + byte. 1 to: count do: [:i {Int32} | num _ (num bitShift: 8) + myReadStream getByte]. ^ num! {void} respondBooleanVar: val {BooleanVar} myError == NULL ifTrue: [self flushAcks. self sendResponse: PromiseManager humberResponse. [self sendIntegerVar: val. myActuals at: myNextClientPromise introduce: (PrimIntValue make: val)] translateOnly. [self sendIntegerVar: (val ifTrue: [1] ifFalse: [0]). myActuals at: myNextClientPromise introduce: (PrimIntValue make: (val ifTrue: [1] ifFalse: [0]))] smalltalkOnly. myNextClientPromise _ myNextClientPromise + 1]! {void} respondHeaper: result {Heaper} result == NULL ifTrue: [Heaper BLAST: #NullResponseResult]. myError == NULL ifTrue: [result cast: PrimIntValue into: [ :i | self flushAcks. self sendResponse: PromiseManager humberResponse. self sendIntegerVar: i asIntegerVar] cast: PrimFloatValue into: [ :f | self flushAcks. self sendResponse: PromiseManager IEEEResponse. f bitCount = 64 ifTrue: [self sendIEEE64: f asIEEE64] ifFalse: [f bitCount = 32 ifTrue: [self sendIEEE32: f asIEEE32] ifFalse: [self unimplemented]]] others: [myAcks _ myAcks + 1]. myActuals at: myNextClientPromise introduce: result. (result isKindOf: FeDetector) ifTrue: [| refCt {IntegerVar} | refCt _ myRefCounts fetch: result. refCt == -1 ifTrue: [myRefCounts at: result introduce: 1] ifFalse: [myRefCounts remove: result. myRefCounts at: result introduce: refCt + 1]]. myNextClientPromise _ myNextClientPromise + 1]! {void} respondIntegerVar: val {IntegerVar} myError == NULL ifTrue: [self flushAcks. self sendResponse: PromiseManager humberResponse. self sendIntegerVar: val. myActuals at: myNextClientPromise introduce: (PrimIntValue make: val). myNextClientPromise _ myNextClientPromise + 1]! {void} respondVoid myError == NULL ifTrue: [myAcks _ myAcks + 1. myNextClientPromise _ myNextClientPromise + 1]! {void} sendIEEE32: f {IEEE32} 'this->sendIntegerVar (4); for (UInt32 i = 0; i < 4; i++) { myWriteStream->putByte (((UInt8 *) &f) [i]); }' translateOnly. [self unimplemented] smalltalkOnly.! {void} sendIEEE64: f {IEEE64} 'this->sendIntegerVar (8); for (UInt32 i = 0; i < 8; i++) { myWriteStream->putByte (((UInt8 *) &f) [i]); }' translateOnly. [self unimplemented] smalltalkOnly.! {void} sendIntegerVar: num {IntegerVar} "Send a Dean style humber. Like Drexler style, except all the tag bits go into the first byte." " 7/1 0<7> 14/2 10<6> <8> 21/3 110<5> <16> 28/4 1110<4> <24> 35/5 11110<3> <32> 42/6 111110<2> <40> 49/7 1111110<1> <48> 56/8 11111110 <56> +/+ 11111111 " | abs {IntegerVar} low32 {Int32} | num < IntegerVarZero ifTrue: [abs _ num negated] ifFalse: [abs _ num]. low32 _ (num bitAnd: ("(1 bitShift: 32) -1" 4294967295)) DOTasLong. num < "1 bitShift: 6" 64 ifTrue: [myWriteStream putByte: (low32 bitAnd: 127). ^VOID]. abs < "1 bitShift: 13" 8192 ifTrue: [myWriteStream putByte: (((low32 bitShiftRight: 8) bitAnd: 2r0111111) bitOr: 2r10000000). myWriteStream putByte: (low32 bitAnd: 255). ^VOID]. abs < "1 bitShift: 20" 1048576 ifTrue: [myWriteStream putByte: (((low32 bitShiftRight: 16) bitAnd: 2r011111) bitOr: 2r11000000). myWriteStream putByte: ((low32 bitShiftRight: 8) bitAnd: 255). myWriteStream putByte: (low32 bitAnd: 255). ^VOID]. abs < "1 bitShift: 27" 134217728 ifTrue: [myWriteStream putByte: (((low32 bitShiftRight: 24) bitAnd: 2r00001111) bitOr: 2r11100000). myWriteStream putByte: ((low32 bitShiftRight: 16) bitAnd: 255). myWriteStream putByte: ((low32 bitShiftRight: 8) bitAnd: 255). myWriteStream putByte: (low32 bitAnd: 255). ^VOID]. "abs < (1 bitShift: 34)" true ifTrue: ["do shift in two steps to get around Sparc shift bug /ravi/7/23/92/" myWriteStream putByte: ((((num bitShiftRight: 16) bitShiftRight: 16) bitAnd: 2r0111) bitOr: 2r11110000) DOTasLong. myWriteStream putByte: ((num bitShiftRight: 24) bitAnd: 255) DOTasLong. myWriteStream putByte: ((num bitShiftRight: 16) bitAnd: 255) DOTasLong. myWriteStream putByte: ((num bitShiftRight: 8) bitAnd: 255) DOTasLong. myWriteStream putByte: (num bitAnd: 255) DOTasLong. ^VOID]. "self sendIntegerVar: (abs log: 256) truncated + 1." "The humber count." Eric shouldImplement "Write out each of the bytes."! {void} sendPromise: heaper {Heaper} "Register heaper with the next Server promise number and increment it. The client must stay in sync." myActuals at: myNextServerPromise introduce: heaper. myNextServerPromise _ myNextServerPromise - 1! {void} sendResponse: num {Int32} "Use a representation optimized for small positive numbers." "If the number is less than 255 then just send it. Otherwise send 255, subtract 255 and recur." | val {Int32} | val _ num. [num < 255] whileFalse: [myWriteStream putByte: 255. val _ val - 255]. myWriteStream putByte: (val basicCast: UInt8)! ! !PromiseManager methodsFor: 'arrays'! {void} sendHumbers: array {IntegerVarArray} with: count {Int32} with: start {Int32} "Send a bunch of IntegerVars to the client." | maxx {Int32} | maxx _ start + count. maxx > array count ifTrue: [Heaper BLAST: #OutOfBounds]. self flushAcks. self sendResponse: PromiseManager humbersResponse. self sendIntegerVar: count. myActuals at: myNextClientPromise introduce: (PrimIntValue make: count). start almostTo: maxx do: [:i {Int32} | self sendIntegerVar: (array integerVarAt: i)]. myNextClientPromise _ myNextClientPromise + 1! {void} sendIEEEs: array {PrimFloatArray} with: count {Int32} with: start {Int32} "Send a bunch of fixed precision integers to the client." | size {Int32} buffer {UInt8Array} | start + count > array count ifTrue: [Heaper BLAST: #OutOfBounds]. self flushAcks. self sendResponse: PromiseManager IEEEsResponse. self sendIntegerVar: array bitCount // 8. self sendIntegerVar: count. myActuals at: myNextClientPromise introduce: (PrimIntValue make: count). size _ array bitCount // 8 * count. buffer _ (PrimIntArray zeros: 8 with: size) cast: UInt8Array. [array copyToBuffer: buffer gutsOf with: size with: count with: start] valueNowOrOnUnwindDo: (UInt8Array bomb.ReleaseGuts: buffer). [myShuffler shuffle: array bitCount with: buffer gutsOf with: count] valueNowOrOnUnwindDo: (UInt8Array bomb.ReleaseGuts: buffer). myWriteStream putData: buffer. myNextClientPromise _ myNextClientPromise + 1! {void} sendInts: array {PrimIntArray} with: count {Int32} with: start {Int32} "Send a bunch of fixed precision integers to the client." | size {Int32} buffer {UInt8Array} | start + count > array count ifTrue: [Heaper BLAST: #OutOfBounds]. self flushAcks. self sendResponse: PromiseManager intsResponse. self sendIntegerVar: array bitCount. self sendIntegerVar: count. myActuals at: myNextClientPromise introduce: (PrimIntValue make: count). size _ array bitCount abs // 8 * count. buffer _ (PrimIntArray zeros: 8 with: size) cast: UInt8Array. [array copyToBuffer: buffer gutsOf with: size with: count with: start] valueNowOrOnUnwindDo: (UInt8Array bomb.ReleaseGuts: buffer). [myShuffler shuffle: array bitCount abs with: buffer gutsOf with: count] valueNowOrOnUnwindDo: (UInt8Array bomb.ReleaseGuts: buffer). myWriteStream putData: buffer. myNextClientPromise _ myNextClientPromise + 1! {void} sendPromises: array {PtrArray} with: count {Int32} with: start {Int32} "Register heaper with the next Server promise number and increment it. The client must stay in sync." | maxx {Int32} nulls {Int32} ptrs {Int32} | maxx _ start + count. maxx > array count ifTrue: [Heaper BLAST: #OutOfBounds]. nulls _ Int32Zero. ptrs _ Int32Zero. self flushAcks. self sendResponse: PromiseManager promisesResponse. self sendIntegerVar: count. myActuals at: myNextClientPromise introduce: (PrimIntValue make: count). start almostTo: maxx do: [:i {Int32} | | elem {Heaper | NULL} | elem _ array fetch: i. elem == NULL ifTrue: [nulls <= Int32Zero ifTrue: [self sendIntegerVar: ptrs. ptrs _ Int32Zero]. nulls _ nulls + 1] ifFalse: [nulls > Int32Zero ifTrue: [self sendIntegerVar: nulls. nulls _ Int32Zero]. self sendPromise: elem. ptrs _ ptrs + 1]]. ptrs >= 1 ifTrue: [self sendIntegerVar: ptrs]. nulls >= 1 ifTrue: [self sendIntegerVar: nulls]. myNextClientPromise _ myNextClientPromise + 1! ! !PromiseManager methodsFor: 'private: comm'! {void} actualWaive: prnum {IntegerVar} "Release the promise argument. This could return a value because the PromiseManager doesn't keep any state for void promises." | actual {Heaper} count {IntegerVar} | actual _ myActuals fetch: prnum. (myActuals fetch: prnum) ~~ NULL ifTrue: [myActuals remove: prnum]. count _ myRefCounts fetch: actual. count == Int32Zero ifTrue: [Heaper BLAST: #RefCountBug]. count > Int32Zero ifTrue: [count == 1 ifTrue: [myRefCounts remove: actual. actual destroy] ifFalse: [myRefCounts at: actual introduce: count - 1]]! {IntegerVar} clientPromiseNumber ^myNextClientPromise! {void} flushAcks "If any acks have accumulated, flush them." myAcks > IntegerVarZero ifTrue: [self sendResponse: PromiseManager ackResponse. self sendIntegerVar: myAcks. myAcks _ IntegerVarZero]! {XnReadStream} readStream ^myReadStream! {Int32} receiveRequestNumber "Receive a request number. The first byte is either between 0 and 254 or it is 255 and the second byte + 255 is the number." | byte {Int32} | byte _ myReadStream getByte. byte < 255 ifTrue: [^byte]. ^myReadStream getByte + 255! {void} respondError self flushAcks. myError isExcused ifTrue: [self sendResponse: PromiseManager excusedResponse. self sendIntegerVar: myError promise] ifFalse: [self sendResponse: PromiseManager errorResponse. self sendIntegerVar: myError error. self sendIntegerVar: Int32Zero]. myNextClientPromise _ myNextClientPromise + 1. myError _ NULL! {void} respondProblem: problem {Problem} BlastLog << 'Blast sent: ' << problem getProblemName << ' at: '. BlastLog << problem getFileName << ':' << problem getLineNumber << ' '. [Logger] USES. self flushAcks. self sendResponse: PromiseManager errorResponse. self sendIntegerVar: (PromiseManager problemNumber: problem getProblemName). self sendIntegerVar: (PromiseManager problemSource: problem getFileName with: problem getLineNumber). myNextClientPromise _ myNextClientPromise + 1. myError _ NULL! {IntegerVar} serverPromiseNumber ^myNextServerPromise! ! !PromiseManager methodsFor: 'protected: creation'! create: portal {Portal} with: clientID {char star} with: shuffler {ByteShuffler} super create. myPortal _ portal. myReadStream _ portal readStream. myWriteStream _ portal writeStream. myActuals _ PrimPtrTable make: 5000. myRefCounts _ PrimIndexTable make: 63. myDetectorEvents _ NULL. myNextClientPromise _ 1. myNextServerPromise _ -1. self thingToDo. "This should get a table based on the clientID." myHandlers _ PromiseManager makeRequestTable. clientID delete. myAcks _ Int32Zero. myError _ NULL. amInsideRequest _ false. myShuffler _ shuffler.! {void} destruct | step {PrimIndexTableStepper} | myPortal destroy. "clean up all the ref counted Detectors" step _ myRefCounts stepper. [step hasValue] whileTrue: [ | detect {Heaper} | detect _ step key. detect destroy. step step]. super destruct! ! !PromiseManager methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PromiseManager class instanceVariableNames: ''! (PromiseManager getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !PromiseManager class methodsFor: 'exceptions: exceptions'! problems.EVERY.U.COMM ^self signals: #(ALL.U.BUT SUBCLASS.U.RESPONSIBILITY URDI.U.JACKPOT MEM.U.ALLOC.U.ERROR NULL.U.CHKPTR PURE.U.VIRTUAL NullResponseResult SOCKET.U.RECV.U.ERROR SOCKET.U.SEND.U.ERROR SanityViolation)! ! !PromiseManager class methodsFor: 'constants'! {Int32} ackResponse ^Int32Zero! {Int32} doneResponse ^14! {Int32} errorResponse ^1! {Int32} excusedResponse ^2! {Int32} filledResponse ^13! {Int32} grabbedResponse ^9! {Int32} humberResponse ^3! {Int32} humbersResponse ^5! {Int32} IEEEResponse ^4! {Int32} IEEEsResponse ^7! {Int32} intsResponse ^6! {Int32} problemNumber: prob {char star} "The number that gets sent over the wire for the given problem name" "PromiseManager problemNumber: 'VALUE_IS_UNKIND' " ^(FHash fastHash.String: prob) bitAnd: 16777215! {Int32} problemSource: file {char star} with: line {int} "The number that gets sent over the wire for the given problem file/line number" ^((((FHash fastHash.String: file) bitAnd: 65535) bitShift: 15) bitXor: (line bitAnd: 32767))! {Int32} promisesResponse ^8! {Int32} rangeFilledResponse ^12! {Int32} releasedResponse ^10! {Int32} revisedResponse ^11! {Int32} terminatedResponse ^15! ! !PromiseManager class methodsFor: 'smalltalk: init'! initTimeNonInherited PromiseClasses _ PtrArray nulls: 100. self fillClassTable: PromiseClasses. AllRequests _ PtrArray nulls: 500. AllRequests storeAll: (SpecialHandler make: (PromiseManager pointerToStaticMember: #noRequest: with: 'VHFn')). self fillRequestTable: AllRequests. "LoginRequests _ PtrArray nulls: 500. LoginRequests storeAll: (SpecialHandler make: (PromiseManager pointerToStaticMember: #notLoginRequest: with: 'VHFn'))."! linkTimeNonInherited PromiseClasses _ NULL. AllRequests _ NULL. "LoginRequests _ NULL" Logger defineLogger: #BlastLog.! ! !PromiseManager class methodsFor: 'creation'! make: portal {Portal} | reader {Rcvr} writer {Xmtr} target {char star} shuffler {ByteShuffler} | reader _ TextyXcvrMaker makeReader: portal readStream. writer _ TextyXcvrMaker makeWriter: portal writeStream. self thingToDo. "Make the following loop a helper routine." "Meta-protocol" target _ reader receiveString. [(String strcmp: target with: 'simple') = Int32Zero] whileFalse: [target delete. target _ NULL. writer sendString: 'no!!'. target _ reader receiveString]. writer sendString: 'yes'. target delete. target _ NULL. "Architecture." target _ reader receiveString. [(String strcmp: target with: 'sun') = Int32Zero or: [(String strcmp: target with: 'intel') = Int32Zero]] whileFalse: [target delete. target _ NULL. writer sendString: 'no!!'. target _ reader receiveString]. [((OSHandle informVM quickSearch: target) == Int32Zero) ifTrue: [shuffler _ SimpleShuffler create] ifFalse: [shuffler _ NoShuffler create]] smalltalkOnly. [((String strcmp: target with: 'intel') == Int32Zero) ifTrue: [shuffler _ SimpleShuffler create] ifFalse: [shuffler _ NoShuffler create]] translateOnly. target delete. target _ NULL. writer sendString: 'yes'. "Syntax" target _ reader receiveString. [(String strcmp: target with: 'binary2') = Int32Zero] whileFalse: [target delete. target _ NULL. writer sendString: 'no!!'. target _ reader receiveString]. target delete. target _ NULL. writer sendString: 'yes'. "Semantics" target _ reader receiveString. [(String strcmp: target with: 'febe92.2') = Int32Zero] whileFalse: [target delete. target _ NULL. writer sendString: 'no!!'. target _ reader receiveString]. writer sendString: 'yes'. writer destroy. reader destroy. ^PromiseManager create: portal with: target with: shuffler.! ! !PromiseManager class methodsFor: 'detector requests'! {void} fillDetector: pm {PromiseManager} "Create the comm detector and add it." | rangeElement {FeRangeElement | NULL} | rangeElement _ (pm fetchNonNullHeaper: FeRangeElement) cast: FeRangeElement. pm noErrors ifTrue: [| detector {FeFillDetector} | detector _ CommFillDetector make: pm with: pm clientPromiseNumber with: rangeElement. rangeElement addFillDetector: detector. pm respondHeaper: detector]! {void} fillRangeDetector: pm {PromiseManager} "Create the comm detector and add it." | receiver {FeEdition | NULL} | receiver _ (pm fetchNonNullHeaper: FeEdition) cast: FeEdition. pm noErrors ifTrue: [| detector {FeFillRangeDetector} | detector _ CommFillRangeDetector make: pm with: pm clientPromiseNumber with: receiver. receiver addFillRangeDetector: detector. pm respondHeaper: detector]! {void} revisionDetector: pm {PromiseManager} "Create the comm detector and add it." | receiver {FeWork | NULL} | receiver _ (pm fetchNonNullHeaper: FeWork) cast: FeWork. pm noErrors ifTrue: [| detector {FeRevisionDetector} | detector _ CommRevisionDetector make: pm with: pm clientPromiseNumber with: receiver. receiver addRevisionDetector: detector. pm respondHeaper: detector]! {void} statusDetector: pm {PromiseManager} "Create the comm detector and add it." | receiver {FeWork | NULL} | receiver _ (pm fetchNonNullHeaper: FeWork) cast: FeWork. pm noErrors ifTrue: [| detector {FeStatusDetector} | detector _ CommStatusDetector make: pm with: pm clientPromiseNumber with: receiver. receiver addStatusDetector: detector. pm respondHeaper: detector]! {void} waitForConsequences: pm {PromiseManager} "Create the comm detector and add it." | detector {FeWaitDetector} | detector _ CommWaitDetector make: pm with: pm clientPromiseNumber. FeServer waitForConsequences: detector. pm respondHeaper: detector! {void} waitForWrite: pm {PromiseManager} "Create the comm detector and add it." | detector {FeWaitDetector} | detector _ CommWaitDetector make: pm with: pm clientPromiseNumber. FeServer waitForWrite: detector. pm respondHeaper: detector! ! !PromiseManager class methodsFor: 'misc requests'! {void} delayCast: pm {PromiseManager} | result {Heaper} cat {Category} | result _ pm fetchHeaper: Heaper. cat _ pm fetchCategory. pm noErrors ifTrue: [(result == NULL or: [result isKindOf: cat]) ifFalse: [Heaper BLAST: #CastFailed]. pm respondHeaper: result]! {void} equals: pm {PromiseManager} | me {Heaper} him {Heaper} | me _ pm fetchNonNullHeaper: Heaper. him _ pm fetchNonNullHeaper: Heaper. pm noErrors ifTrue: [pm respondBooleanVar: (me isEqual: him)]! {void} export0: pm {PromiseManager} "The zero argument version of PrimArray export." | array {PrimArray} | array _ (pm fetchNonNullHeaper: PrimArray) cast: PrimArray. pm noErrors ifTrue: [array cast: PrimIntArray into: [:a | pm sendInts: a with: a count with: Int32Zero] cast: IntegerVarArray into: [:a | pm sendHumbers: a with: a count with: Int32Zero] cast: PtrArray into: [:a | pm sendPromises: a with: a count with: Int32Zero] cast: PrimFloatArray into: [:a | pm sendIEEEs: a with: a count with: Int32Zero]]! {void} export1: pm {PromiseManager} "The one argument version of PrimArray export." | array {PrimArray} count {Int32} | array _ (pm fetchNonNullHeaper: PrimArray) cast: PrimArray. count _ pm fetchInt32. pm noErrors ifTrue: [array cast: PrimIntArray into: [:a | pm sendInts: a with: count with: Int32Zero] cast: IntegerVarArray into: [:a | pm sendHumbers: a with: count with: Int32Zero] cast: PtrArray into: [:a | pm sendPromises: a with: count with: Int32Zero] cast: PrimFloatArray into: [:a | pm sendIEEEs: a with: count with: Int32Zero]]! {void} export2: pm {PromiseManager} "The two argument version of PrimArray export." | array {PrimArray} count {Int32} start {Int32} | array _ (pm fetchNonNullHeaper: PrimArray) cast: PrimArray. count _ pm fetchInt32. start _ pm fetchInt32. pm noErrors ifTrue: [array cast: PrimIntArray into: [:a | pm sendInts: a with: count with: start] cast: IntegerVarArray into: [:a | pm sendHumbers: a with: count with: start] cast: PtrArray into: [:a | pm sendPromises: a with: count with: start] cast: PrimFloatArray into: [:a | pm sendIEEEs: a with: count with: start]]! {void} forceIt: pm {PromiseManager} pm force! {PtrArray of: RequestHandler} makeRequestTable "PromiseManager makeRequestTable." | table {PtrArray} | table _ PtrArray nulls: 500. table storeAll: (SpecialHandler make: (PromiseManager pointerToStaticMember: #noRequest: with: 'VHFn')). self fillRequestTable: table. ^table! {void} noRequest: pm {PromiseManager unused} "For illegal requests." Heaper BLAST: #BadRequest! {void} notLoggedInRequest: pm {PromiseManager unused} "For illegal requests." Heaper BLAST: #NotLoggedIn! {void} promiseHash: pm {PromiseManager} | me {Heaper} | me _ pm fetchNonNullHeaper: Heaper. pm noErrors ifTrue: [pm respondIntegerVar: me hashForEqual]! {void} setCurrentAuthor: pm {PromiseManager} "The one argument version of PrimArray export." | iD {ID} | iD _ (pm fetchHeaper: ID) cast: ID. pm noErrors ifTrue: [FeServer setCurrentAuthor: iD]! {void} setCurrentKeyMaster: pm {PromiseManager} "Set the fluid." | keymaster {FeKeyMaster} | keymaster _ (pm fetchHeaper: FeKeyMaster) cast: FeKeyMaster. pm noErrors ifTrue: [FeServer setCurrentKeyMaster: keymaster]! {void} setInitialEditClub: pm {PromiseManager} "Set the fluid." | iD {ID} | iD _ (pm fetchHeaper: ID) cast: ID. pm noErrors ifTrue: [FeServer setInitialEditClub: iD]! {void} setInitialOwner: pm {PromiseManager} "Set the fluid." | iD {ID} | iD _ (pm fetchHeaper: ID) cast: ID. pm noErrors ifTrue: [FeServer setInitialOwner: iD]! {void} setInitialReadClub: pm {PromiseManager} "Set the fluid." | iD {ID} | iD _ (pm fetchHeaper: ID) cast: ID. pm noErrors ifTrue: [FeServer setInitialReadClub: iD]! {void} setInitialSponsor: pm {PromiseManager} "Set the fluid." | iD {ID} | iD _ (pm fetchHeaper: ID) cast: ID. pm noErrors ifTrue: [FeServer setInitialSponsor: iD]! {void} shutdown: pm {PromiseManager} | adm {FeAdminer} | adm := (pm fetchNonNullHeaper: FeAdminer) cast: FeAdminer. pm noErrors ifTrue: [pm force. adm shutdown]! {void} testKindOf: pm {PromiseManager} | result {Heaper} cat {Category} | result _ pm fetchNonNullHeaper: Heaper. cat _ pm fetchCategory. pm noErrors ifTrue: [pm respondBooleanVar: (result isKindOf: cat)]! {void} waiveEm: pm {PromiseManager} pm waiveMany! {void} waiveIt: pm {PromiseManager} pm waive! ! !PromiseManager class methodsFor: 'making requests'! {void} makeFloat: pm {PromiseManager} " * " | size {Int32} | size _ pm receiveIntegerVar DOTasLong. size = 4 ifTrue: ['IEEE32 f; pm->readStream ()->getBytes ((void *) &f, 4); pm->respondHeaper (PrimIEEE32::make (f)); return;' translateOnly] ifFalse: [size = 8 ifTrue: ['IEEE64 f; pm->readStream ()->getBytes ((void *) &f, 8); pm->respondHeaper (PrimIEEE64::make (f)); return;' translateOnly]]. size timesRepeat: [pm readStream getByte]. pm noErrors ifTrue: [self unimplemented]! {void} makeFloatArray: pm {PromiseManager} | sizeofFloat {IntegerVar} count {IntegerVar} | sizeofFloat _ pm receiveIntegerVar. count _ pm receiveIntegerVar. pm noErrors ifTrue: [| size {Int32} buffer {UInt8 vector} result {PrimFloatArray} | size _ (sizeofFloat * count) DOTasLong. [buffer _ UInt8Array make: size] smalltalkOnly. 'if (size > 0) { buffer = new UInt8[size]; } else { buffer = NULL; }' translateOnly. pm readStream getBytes: buffer with: size. result _ ((PrimSpec iEEE: (sizeofFloat * 8) DOTasLong) arrayFromBuffer: count DOTasLong with: buffer) cast: PrimFloatArray. buffer ~~ NULL ifTrue: [buffer delete]. pm respondHeaper: result]! {void} makeHumber: pm {PromiseManager} | num {IntegerVar} | num _ pm receiveIntegerVar. pm noErrors ifTrue: [pm respondHeaper: (PrimIntValue make: num)]! {void} makeHumberArray: pm {PromiseManager} | count {Int32} result {PrimIntegerArray} | count _ pm receiveIntegerVar DOTasLong. result _ IntegerVarArray zeros: count. Int32Zero almostTo: count do: [:i {Int32} | result at: i storeInteger: pm receiveIntegerVar]. pm noErrors ifTrue: [pm respondHeaper: result]! {void} makeIntArray: pm {PromiseManager} | precision {IntegerVar} count {IntegerVar} size {Int32} buffer {UInt8 vector} bits {Int32} spec {PrimSpec} result {PrimIntegerArray} | precision _ pm receiveIntegerVar. count _ pm receiveIntegerVar. bits _ precision abs DOTasLong. size _ (precision abs // 8 * count) DOTasLong. [buffer _ UInt8Array make: size] smalltalkOnly. 'if (size > 0) { buffer = new UInt8[size]; } else { buffer = NULL; }' translateOnly. pm readStream getBytes: buffer with: size. precision < Int32Zero ifTrue: [spec _ PrimSpec signedInteger: bits] ifFalse: [spec _ PrimSpec unsignedInteger: bits]. result _ (spec arrayFromBuffer: count DOTasLong with: buffer) cast: PrimIntegerArray. buffer ~~ NULL ifTrue: [buffer delete]. pm respondHeaper: result! {void} makePtrArray: pm {PromiseManager} "If any of the promises is an error, then pm won't return the PtrArray." | count {Int32} result {PtrArray} | count _ pm receiveIntegerVar DOTasLong. result _ PtrArray nulls: count. Int32Zero almostTo: count do: [:i {Int32} | result at: i store: (pm fetchHeaper: Heaper)]. pm noErrors ifTrue: [pm respondHeaper: result]! ! !PromiseManager class methodsFor: 'smalltalk: generation'! mapOverride: sel with: class with: argCount "The table of classes and their selectors overridden by special handlers." "PromiseManager mapOverride: 'waive' with: 'Promise' with: 0" | array | array _ #( ('Promise cast 1' delayCast:) ('Promise isKindOf 1' testKindOf:) ('Promise waive 0' waiveIt:) ('Promise waiveMany 1' waiveEm:) ('Promise equals 1' equals:) ('Promise hash 0' promiseHash:) ('Server force 0' forceIt:) ('Adminer shutdown 0' shutdown:) ('Array export 0' export0:) ('Array export 1' export1:) ('Array export 2' export2:) ('FloatValue import 1' makeFloat:) ('FloatArray import 1' makeFloatArray:) ('IntValue import 1' makeHumber:) ('HumberArray import 1' makeHumberArray:) ('IntArray import 1' makeIntArray:) ('PtrArray import 1' makePtrArray:) ('RangeElement fillDetector 0' fillDetector:) ('Edition fillRangeDetector 0' fillRangeDetector:) ('Work revisionDetector 0' revisionDetector:) ('Work statusDetector 0' statusDetector:) ('Server setCurrentAuthor 1' setCurrentAuthor:) ('Server setCurrentKeyMaster 1' setCurrentKeyMaster:) ('Server setInitialEditClub 1' setInitialEditClub:) ('Server setInitialOwner 1' setInitialOwner:) ('Server setInitialReadClub 1' setInitialReadClub:) ('Server setInitialSponsor 1' setInitialSponsor:) ('Server waitForConsequences 0' waitForConsequences:) ('Server waitForWrite 0' waitForWrite:) ). array ~~ OverrideArray ifTrue: [OverrideArray _ array. OverrideMap _ Dictionary fromPairs: array]. ^OverrideMap at: (String streamContents: [:pp | pp << class << ' ' << sel << ' ' << argCount]) ifAbsent: []! ! !PromiseManager class methodsFor: 'smalltalk: passe'! {void} force: pm {PromiseManager} self passe. "use forceIt"! {void} waive: pm {PromiseManager} self passe! ! !PromiseManager class methodsFor: 'translate: generated'! {void} fillClassTable: table {PtrArray} table at: 1 storeValue: Heaper. table at: 2 storeValue: FeAdminer. table at: 3 storeValue: FeArchiver. table at: 4 storeValue: PrimArray. table at: 5 storeValue: PrimFloatArray. table at: 6 storeValue: IntegerVarArray. table at: 7 storeValue: PrimIntArray. table at: 8 storeValue: PtrArray. table at: 9 storeValue: FeBundle. table at: 10 storeValue: FeArrayBundle. table at: 11 storeValue: FeElementBundle. table at: 12 storeValue: FePlaceHolderBundle. table at: 13 storeValue: CoordinateSpace. table at: 14 storeValue: CrossSpace. table at: 15 storeValue: FilterSpace. table at: 16 storeValue: IDSpace. table at: 17 storeValue: IntegerSpace. table at: 18 storeValue: RealSpace. table at: 19 storeValue: SequenceSpace. table at: 20 storeValue: FeFillRangeDetector. table at: 21 storeValue: FeFillDetector. table at: 22 storeValue: FeKeyMaster. table at: 23 storeValue: Lock. table at: 24 storeValue: BooLock. table at: 25 storeValue: ChallengeLock. table at: 26 storeValue: MatchLock. table at: 27 storeValue: MultiLock. table at: 28 storeValue: WallLock. table at: 29 storeValue: Mapping. table at: 30 storeValue: CrossMapping. table at: 31 storeValue: IntegerMapping. table at: 32 storeValue: SequenceMapping. table at: 33 storeValue: OrderSpec. table at: 34 storeValue: CrossOrderSpec. table at: 35 storeValue: Position. table at: 36 storeValue: FilterPosition. table at: 37 storeValue: ID. table at: 38 storeValue: Sequence. table at: 39 storeValue: Tuple. table at: 40 storeValue: IntegerPos. table at: 41 storeValue: RealPos. table at: 42 storeValue: FeRangeElement. table at: 43 storeValue: FeDataHolder. table at: 44 storeValue: FeEdition. table at: 45 storeValue: FeIDHolder. table at: 46 storeValue: FeLabel. table at: 47 storeValue: FeWork. table at: 48 storeValue: FeClub. table at: 49 storeValue: FeRevisionDetector. table at: 50 storeValue: FeServer. table at: 51 storeValue: FeSession. table at: 52 storeValue: FeStatusDetector. table at: 53 storeValue: Stepper. table at: 54 storeValue: TableStepper. table at: 55 storeValue: FeWaitDetector. table at: 56 storeValue: FeWrapper. table at: 57 storeValue: FeClubDescription. table at: 58 storeValue: FeHyperLink. table at: 59 storeValue: FeHyperRef. table at: 60 storeValue: FeMultiRef. table at: 61 storeValue: FeSingleRef. table at: 62 storeValue: FeLockSmith. table at: 63 storeValue: FeBooLockSmith. table at: 64 storeValue: FeChallengeLockSmith. table at: 65 storeValue: FeMatchLockSmith. table at: 66 storeValue: FeMultiLockSmith. table at: 67 storeValue: FeWallLockSmith. table at: 68 storeValue: FePath. table at: 69 storeValue: FeSet. table at: 70 storeValue: FeText. table at: 71 storeValue: FeWrapperSpec. table at: 72 storeValue: XnRegion. table at: 73 storeValue: CrossRegion. table at: 74 storeValue: Filter. table at: 75 storeValue: IDRegion. table at: 76 storeValue: IntegerRegion. table at: 77 storeValue: RealRegion. table at: 78 storeValue: SequenceRegion. table at: 79 storeValue: PrimValue. table at: 80 storeValue: PrimFloatValue. table at: 81 storeValue: PrimIntValue.! {void} fillRequestTable1: table {PtrArray} table at: 27 storeValue: (HHandler make: (RequestHandler pointerToStaticMember: #IDSpace.U.unique.U.N0 with: 'HFn')). table at: 283 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #IDSpace.U.export.U.N1: with: 'HHFn') with: IDSpace). table at: 430 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #IDSpace.U.iDsFromServer.U.N2:with: with: 'HHHFn') with: IDSpace with: Sequence). table at: 28 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #IDSpace.U.newID.U.N1: with: 'HHFn') with: IDSpace). table at: 29 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #IDSpace.U.newIDs.U.N2:with: with: 'HHHFn') with: IDSpace with: PrimIntValue). "Requests for class IntegerSpace" table at: 30 storeValue: (HHandler make: (RequestHandler pointerToStaticMember: #IntegerSpace.U.make.U.N0 with: 'HFn')). table at: 31 storeValue: (HHBHandler make: (RequestHandler pointerToStaticMember: #IntegerSpace.U.above.U.N2:with: with: 'HHBFn') with: IntegerPos). table at: 32 storeValue: (HHBHandler make: (RequestHandler pointerToStaticMember: #IntegerSpace.U.below.U.N2:with: with: 'HHBFn') with: IntegerPos). table at: 33 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #IntegerSpace.U.interval.U.N2:with: with: 'HHHFn') with: IntegerPos with: IntegerPos). table at: 34 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #IntegerSpace.U.position.U.N1: with: 'HHFn') with: PrimIntValue). table at: 35 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #IntegerSpace.U.translation.U.N1: with: 'HHFn') with: PrimIntValue). "Requests for class RealSpace" table at: 284 storeValue: (HHandler make: (RequestHandler pointerToStaticMember: #RealSpace.U.make.U.N0 with: 'HFn')). table at: 36 storeValue: (HHHBHandler make: (RequestHandler pointerToStaticMember: #RealSpace.U.above.U.N3:with:with: with: 'HHHBFn') with: RealSpace with: RealPos). table at: 37 storeValue: (HHHBHandler make: (RequestHandler pointerToStaticMember: #RealSpace.U.below.U.N3:with:with: with: 'HHHBFn') with: RealSpace with: RealPos). table at: 38 storeValue: (HHHHHandler make: (RequestHandler pointerToStaticMember: #RealSpace.U.interval.U.N3:with:with: with: 'HHHHFn') with: RealSpace with: RealPos with: RealPos). table at: 39 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #RealSpace.U.position.U.N2:with: with: 'HHHFn') with: RealSpace with: PrimFloatValue). "Requests for class SequenceSpace" table at: 40 storeValue: (HHandler make: (RequestHandler pointerToStaticMember: #SequenceSpace.U.make.U.N0 with: 'HFn')). table at: 41 storeValue: (HHBHandler make: (RequestHandler pointerToStaticMember: #SequenceSpace.U.above.U.N2:with: with: 'HHBFn') with: Sequence). table at: 42 storeValue: (HHBHandler make: (RequestHandler pointerToStaticMember: #SequenceSpace.U.below.U.N2:with: with: 'HHBFn') with: Sequence). table at: 43 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #SequenceSpace.U.interval.U.N2:with: with: 'HHHFn') with: Sequence with: Sequence). table at: 285 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #SequenceSpace.U.mapping.U.N1: with: 'HHFn') with: PrimIntValue). table at: 286 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #SequenceSpace.U.mapping.U.N2:with: with: 'HHHFn') with: PrimIntValue with: Sequence). table at: 44 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #SequenceSpace.U.position.U.N1: with: 'HHFn') with: PrimArray). table at: 45 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #SequenceSpace.U.position.U.N2:with: with: 'HHHFn') with: PrimArray with: PrimIntValue). table at: 287 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #SequenceSpace.U.prefixedBy.U.N2:with: with: 'HHHFn') with: Sequence with: PrimIntValue). "Requests for class FillRangeDetector" "Requests for class FillDetector" "Requests for class KeyMaster" table at: 288 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #KeyMaster.U.actualAuthority.U.N1: with: 'HHFn') with: FeKeyMaster). table at: 289 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #KeyMaster.U.copy.U.N1: with: 'HHFn') with: FeKeyMaster). table at: 290 storeValue: (BHHHandler make: (RequestHandler pointerToStaticMember: #KeyMaster.U.hasAuthority.U.N2:with: with: 'BHHFn') with: FeKeyMaster with: ID). table at: 291 storeValue: (VHHHandler make: (RequestHandler pointerToStaticMember: #KeyMaster.U.incorporate.U.N2:with: with: 'VHHFn') with: FeKeyMaster with: FeKeyMaster). table at: 292 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #KeyMaster.U.loginAuthority.U.N1: with: 'HHFn') with: FeKeyMaster). table at: 293 storeValue: (VHHHandler make: (RequestHandler pointerToStaticMember: #KeyMaster.U.removeLogins.U.N2:with: with: 'VHHFn') with: FeKeyMaster with: IDRegion). "Requests for class Lock" "Requests for class BooLock" table at: 431 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #BooLock.U.boo.U.N1: with: 'HHFn') with: BooLock). "Requests for class ChallengeLock" table at: 432 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #ChallengeLock.U.challenge.U.N1: with: 'HHFn') with: ChallengeLock). table at: 433 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #ChallengeLock.U.response.U.N2:with: with: 'HHHFn') with: ChallengeLock with: PrimIntArray). "Requests for class MatchLock" table at: 434 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #MatchLock.U.encryptedPassword.U.N2:with: with: 'HHHFn') with: MatchLock with: PrimIntArray). "Requests for class MultiLock" table at: 435 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #MultiLock.U.lock.U.N2:with: with: 'HHHFn') with: MultiLock with: Sequence). table at: 436 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #MultiLock.U.lockNames.U.N1: with: 'HHFn') with: MultiLock). "Requests for class WallLock" "Requests for class Mapping" table at: 46 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Mapping.U.combine.U.N2:with: with: 'HHHFn') with: Mapping with: Mapping). table at: 47 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Mapping.U.domain.U.N1: with: 'HHFn') with: Mapping). table at: 294 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Mapping.U.domainSpace.U.N1: with: 'HHFn') with: Mapping). table at: 48 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Mapping.U.inverse.U.N1: with: 'HHFn') with: Mapping). table at: 49 storeValue: (BHHandler make: (RequestHandler pointerToStaticMember: #Mapping.U.isComplete.U.N1: with: 'BHFn') with: Mapping). table at: 50 storeValue: (BHHandler make: (RequestHandler pointerToStaticMember: #Mapping.U.isIdentity.U.N1: with: 'BHFn') with: Mapping). table at: 51 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Mapping.U.of.U.N2:with: with: 'HHHFn') with: Mapping with: Position). table at: 52 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Mapping.U.ofAll.U.N2:with: with: 'HHHFn') with: Mapping with: XnRegion). table at: 295 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Mapping.U.range.U.N1: with: 'HHFn') with: Mapping). table at: 296 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Mapping.U.rangeSpace.U.N1: with: 'HHFn') with: Mapping). table at: 53 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Mapping.U.restrict.U.N2:with: with: 'HHHFn') with: Mapping with: XnRegion). table at: 54 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Mapping.U.simplerMappings.U.N1: with: 'HHFn') with: Mapping). table at: 55 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Mapping.U.unrestricted.U.N1: with: 'HHFn') with: Mapping). "Requests for class CrossMapping" table at: 297 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #CrossMapping.U.subMapping.U.N2:with: with: 'HHHFn') with: CrossMapping with: PrimIntValue). table at: 298 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #CrossMapping.U.subMappings.U.N1: with: 'HHFn') with: CrossMapping). "Requests for class IntegerMapping" table at: 56 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #IntegerMapping.U.translation.U.N1: with: 'HHFn') with: IntegerMapping). "Requests for class SequenceMapping" table at: 57 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #SequenceMapping.U.shift.U.N1: with: 'HHFn') with: SequenceMapping). table at: 58 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #SequenceMapping.U.translation.U.N1: with: 'HHFn') with: SequenceMapping). "Requests for class OrderSpec" table at: 299 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #OrderSpec.U.coordinateSpace.U.N1: with: 'HHFn') with: OrderSpec). table at: 59 storeValue: (BHHHHandler make: (RequestHandler pointerToStaticMember: #OrderSpec.U.follows.U.N3:with:with: with: 'BHHHFn') with: OrderSpec with: Position with: Position). table at: 300 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #OrderSpec.U.reversed.U.N1: with: 'HHFn') with: OrderSpec). "Requests for class CrossOrderSpec" table at: 301 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #CrossOrderSpec.U.lexOrder.U.N1: with: 'HHFn') with: CrossOrderSpec). table at: 302 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #CrossOrderSpec.U.subOrder.U.N2:with: with: 'HHHFn') with: CrossOrderSpec with: PrimIntValue). table at: 303 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #CrossOrderSpec.U.subOrders.U.N1: with: 'HHFn') with: CrossOrderSpec). "Requests for class Position" table at: 60 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Position.U.asRegion.U.N1: with: 'HHFn') with: Position). table at: 304 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Position.U.coordinateSpace.U.N1: with: 'HHFn') with: Position). "Requests for class FilterPosition" table at: 437 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #FilterPosition.U.baseRegion.U.N1: with: 'HHFn') with: FilterPosition). "Requests for class ID" table at: 305 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #ID.U.import.U.N1: with: 'HHFn') with: PrimIntArray). table at: 306 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #ID.U.export.U.N1: with: 'HHFn') with: ID). "Requests for class Sequence" table at: 61 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Sequence.U.firstIndex.U.N1: with: 'HHFn') with: Sequence). table at: 307 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Sequence.U.integerAt.U.N2:with: with: 'HHHFn') with: Sequence with: PrimIntValue). table at: 62 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Sequence.U.integers.U.N1: with: 'HHFn') with: Sequence). table at: 63 storeValue: (BHHandler make: (RequestHandler pointerToStaticMember: #Sequence.U.isZero.U.N1: with: 'BHFn') with: Sequence). table at: 308 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Sequence.U.lastIndex.U.N1: with: 'HHFn') with: Sequence). table at: 309 storeValue: (HHHHHandler make: (RequestHandler pointerToStaticMember: #Sequence.U.with.U.N3:with:with: with: 'HHHHFn') with: Sequence with: PrimIntValue with: PrimIntValue). "Requests for class Tuple" table at: 64 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Tuple.U.coordinate.U.N2:with: with: 'HHHFn') with: Tuple with: PrimIntValue). table at: 65 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Tuple.U.coordinates.U.N1: with: 'HHFn') with: Tuple). "Requests for class Integer" table at: 66 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Integer.U.value.U.N1: with: 'HHFn') with: IntegerPos). "Requests for class Real" table at: 67 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Real.U.value.U.N1: with: 'HHFn') with: RealPos). "Requests for class RangeElement" table at: 68 storeValue: (HHandler make: (RequestHandler pointerToStaticMember: #RangeElement.U.placeHolder.U.N0 with: 'HFn')). table at: 310 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #RangeElement.U.again.U.N1: with: 'HHFn') with: FeRangeElement). table at: 311 storeValue: (BHHHandler make: (RequestHandler pointerToStaticMember: #RangeElement.U.canMakeIdentical.U.N2:with: with: 'BHHFn') with: FeRangeElement with: FeRangeElement). table at: 312 storeValue: (SpecialHandler make: (PromiseManager pointerToStaticMember: #fillDetector: with: 'VHFn')). self fillRequestTable2: table.! {void} fillRequestTable2: table {PtrArray} table at: 69 storeValue: (BHHHandler make: (RequestHandler pointerToStaticMember: #RangeElement.U.isIdentical.U.N2:with: with: 'BHHFn') with: FeRangeElement with: FeRangeElement). table at: 70 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #RangeElement.U.label.U.N1: with: 'HHFn') with: FeRangeElement). table at: 313 storeValue: (VHHHandler make: (RequestHandler pointerToStaticMember: #RangeElement.U.makeIdentical.U.N2:with: with: 'VHHFn') with: FeRangeElement with: FeRangeElement). table at: 314 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #RangeElement.U.owner.U.N1: with: 'HHFn') with: FeRangeElement). table at: 71 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #RangeElement.U.relabelled.U.N2:with: with: 'HHHFn') with: FeRangeElement with: FeLabel). table at: 315 storeValue: (VHHHandler make: (RequestHandler pointerToStaticMember: #RangeElement.U.setOwner.U.N2:with: with: 'VHHFn') with: FeRangeElement with: ID). table at: 72 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #RangeElement.U.transcluders.U.N1: with: 'HHFn') with: FeRangeElement). table at: 73 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #RangeElement.U.transcluders.U.N2:with: with: 'HHHFn') with: FeRangeElement with: Filter). table at: 74 storeValue: (HHHHHandler make: (RequestHandler pointerToStaticMember: #RangeElement.U.transcluders.U.N3:with:with: with: 'HHHHFn') with: FeRangeElement with: Filter with: Filter). table at: 75 storeValue: (HHHHHHandler make: (RequestHandler pointerToStaticMember: #RangeElement.U.transcluders.U.N4:with:with:with: with: 'HHHHHFn') with: FeRangeElement with: Filter with: Filter with: PrimIntValue). table at: 316 storeValue: (HHHHHHHandler make: (RequestHandler pointerToStaticMember: #RangeElement.U.transcluders.U.N5:with:with:with:with: with: 'HHHHHHFn') with: FeRangeElement with: Filter with: Filter with: PrimIntValue with: FeEdition). table at: 76 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #RangeElement.U.works.U.N1: with: 'HHFn') with: FeRangeElement). table at: 77 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #RangeElement.U.works.U.N2:with: with: 'HHHFn') with: FeRangeElement with: Filter). table at: 78 storeValue: (HHHHHandler make: (RequestHandler pointerToStaticMember: #RangeElement.U.works.U.N3:with:with: with: 'HHHHFn') with: FeRangeElement with: Filter with: PrimIntValue). table at: 317 storeValue: (HHHHHHandler make: (RequestHandler pointerToStaticMember: #RangeElement.U.works.U.N4:with:with:with: with: 'HHHHHFn') with: FeRangeElement with: Filter with: PrimIntValue with: FeEdition). "Requests for class DataHolder" table at: 79 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #DataHolder.U.make.U.N1: with: 'HHFn') with: PrimValue). table at: 80 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #DataHolder.U.value.U.N1: with: 'HHFn') with: FeDataHolder). "Requests for class Edition" table at: 81 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.empty.U.N1: with: 'HHFn') with: CoordinateSpace). table at: 82 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.fromAll.U.N2:with: with: 'HHHFn') with: XnRegion with: FeRangeElement). table at: 83 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.fromArray.U.N1: with: 'HHFn') with: PrimArray). table at: 84 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.fromArray.U.N2:with: with: 'HHHFn') with: PrimArray with: XnRegion). table at: 318 storeValue: (HHHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.fromArray.U.N3:with:with: with: 'HHHHFn') with: PrimArray with: XnRegion with: OrderSpec). table at: 85 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.fromOne.U.N2:with: with: 'HHHFn') with: Position with: FeRangeElement). table at: 86 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.placeHolders.U.N1: with: 'HHFn') with: XnRegion). table at: 319 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.canMakeRangeIdentical.U.N2:with: with: 'HHHFn') with: FeEdition with: FeEdition). table at: 320 storeValue: (HHHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.canMakeRangeIdentical.U.N3:with:with: with: 'HHHHFn') with: FeEdition with: FeEdition with: XnRegion). table at: 87 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.combine.U.N2:with: with: 'HHHFn') with: FeEdition with: FeEdition). table at: 88 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.coordinateSpace.U.N1: with: 'HHFn') with: FeEdition). table at: 89 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.copy.U.N2:with: with: 'HHHFn') with: FeEdition with: XnRegion). table at: 321 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.cost.U.N2:with: with: 'HHHFn') with: FeEdition with: PrimIntValue). table at: 90 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.count.U.N1: with: 'HHFn') with: FeEdition). table at: 91 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.domain.U.N1: with: 'HHFn') with: FeEdition). table at: 92 storeValue: (VHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.endorse.U.N2:with: with: 'VHHFn') with: FeEdition with: CrossRegion). table at: 93 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.endorsements.U.N1: with: 'HHFn') with: FeEdition). table at: 322 storeValue: (SpecialHandler make: (PromiseManager pointerToStaticMember: #fillRangeDetector: with: 'VHFn')). table at: 94 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.get.U.N2:with: with: 'HHHFn') with: FeEdition with: Position). table at: 95 storeValue: (BHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.hasPosition.U.N2:with: with: 'BHHFn') with: FeEdition with: Position). table at: 96 storeValue: (BHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.isEmpty.U.N1: with: 'BHFn') with: FeEdition). table at: 97 storeValue: (BHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.isFinite.U.N1: with: 'BHFn') with: FeEdition). table at: 323 storeValue: (BHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.isRangeIdentical.U.N2:with: with: 'BHHFn') with: FeEdition with: FeEdition). table at: 324 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.makeRangeIdentical.U.N2:with: with: 'HHHFn') with: FeEdition with: FeEdition). table at: 325 storeValue: (HHHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.makeRangeIdentical.U.N3:with:with: with: 'HHHHFn') with: FeEdition with: FeEdition with: XnRegion). table at: 98 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.mapSharedOnto.U.N2:with: with: 'HHHFn') with: FeEdition with: FeEdition). table at: 326 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.mapSharedTo.U.N2:with: with: 'HHHFn') with: FeEdition with: FeEdition). table at: 99 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.notSharedWith.U.N2:with: with: 'HHHFn') with: FeEdition with: FeEdition). table at: 100 storeValue: (HHHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.notSharedWith.U.N3:with:with: with: 'HHHHFn') with: FeEdition with: FeEdition with: PrimIntValue). table at: 101 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.positionsLabelled.U.N2:with: with: 'HHHFn') with: FeEdition with: FeLabel). table at: 102 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.positionsOf.U.N2:with: with: 'HHHFn') with: FeEdition with: FeRangeElement). table at: 327 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.rangeOwners.U.N2:with: with: 'HHHFn') with: FeEdition with: XnRegion). table at: 103 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.rangeTranscluders.U.N1: with: 'HHFn') with: FeEdition). table at: 104 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.rangeTranscluders.U.N2:with: with: 'HHHFn') with: FeEdition with: XnRegion). table at: 105 storeValue: (HHHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.rangeTranscluders.U.N3:with:with: with: 'HHHHFn') with: FeEdition with: XnRegion with: Filter). table at: 106 storeValue: (HHHHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.rangeTranscluders.U.N4:with:with:with: with: 'HHHHHFn') with: FeEdition with: XnRegion with: Filter with: Filter). table at: 107 storeValue: (HHHHHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.rangeTranscluders.U.N5:with:with:with:with: with: 'HHHHHHFn') with: FeEdition with: XnRegion with: Filter with: Filter with: PrimIntValue). table at: 328 storeValue: (HHHHHHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.rangeTranscluders.U.N6:with:with:with:with:with: with: 'HHHHHHHFn') with: FeEdition with: XnRegion with: Filter with: Filter with: PrimIntValue with: FeEdition). table at: 329 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.rangeWorks.U.N1: with: 'HHFn') with: FeEdition). table at: 330 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.rangeWorks.U.N2:with: with: 'HHHFn') with: FeEdition with: XnRegion). table at: 331 storeValue: (HHHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.rangeWorks.U.N3:with:with: with: 'HHHHFn') with: FeEdition with: XnRegion with: Filter). table at: 332 storeValue: (HHHHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.rangeWorks.U.N4:with:with:with: with: 'HHHHHFn') with: FeEdition with: XnRegion with: Filter with: PrimIntValue). table at: 333 storeValue: (HHHHHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.rangeWorks.U.N5:with:with:with:with: with: 'HHHHHHFn') with: FeEdition with: XnRegion with: Filter with: PrimIntValue with: FeEdition). table at: 108 storeValue: (HHHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.rebind.U.N3:with:with: with: 'HHHHFn') with: FeEdition with: Position with: FeEdition). table at: 109 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.replace.U.N2:with: with: 'HHHFn') with: FeEdition with: FeEdition). table at: 334 storeValue: (VHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.retract.U.N2:with: with: 'VHHFn') with: FeEdition with: CrossRegion). table at: 110 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.retrieve.U.N1: with: 'HHFn') with: FeEdition). table at: 111 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.retrieve.U.N2:with: with: 'HHHFn') with: FeEdition with: XnRegion). table at: 112 storeValue: (HHHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.retrieve.U.N3:with:with: with: 'HHHHFn') with: FeEdition with: XnRegion with: OrderSpec). table at: 113 storeValue: (HHHHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.retrieve.U.N4:with:with:with: with: 'HHHHHFn') with: FeEdition with: XnRegion with: OrderSpec with: PrimIntValue). table at: 335 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.setRangeOwners.U.N2:with: with: 'HHHFn') with: FeEdition with: ID). table at: 336 storeValue: (HHHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.setRangeOwners.U.N3:with:with: with: 'HHHHFn') with: FeEdition with: ID with: XnRegion). table at: 114 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.sharedRegion.U.N2:with: with: 'HHHFn') with: FeEdition with: FeEdition). table at: 115 storeValue: (HHHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.sharedRegion.U.N3:with:with: with: 'HHHHFn') with: FeEdition with: FeEdition with: PrimIntValue). table at: 116 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.sharedWith.U.N2:with: with: 'HHHFn') with: FeEdition with: FeEdition). table at: 117 storeValue: (HHHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.sharedWith.U.N3:with:with: with: 'HHHHFn') with: FeEdition with: FeEdition with: PrimIntValue). table at: 118 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.stepper.U.N1: with: 'HHFn') with: FeEdition). table at: 119 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.stepper.U.N2:with: with: 'HHHFn') with: FeEdition with: XnRegion). table at: 337 storeValue: (HHHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.stepper.U.N3:with:with: with: 'HHHHFn') with: FeEdition with: XnRegion with: OrderSpec). table at: 120 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.theOne.U.N1: with: 'HHFn') with: FeEdition). table at: 121 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.transformedBy.U.N2:with: with: 'HHHFn') with: FeEdition with: Mapping). table at: 122 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.visibleEndorsements.U.N1: with: 'HHFn') with: FeEdition). table at: 123 storeValue: (HHHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.with.U.N3:with:with: with: 'HHHHFn') with: FeEdition with: Position with: FeRangeElement). self fillRequestTable3: table.! {void} fillRequestTable3: table {PtrArray} table at: 124 storeValue: (HHHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.withAll.U.N3:with:with: with: 'HHHHFn') with: FeEdition with: XnRegion with: FeRangeElement). table at: 125 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.without.U.N2:with: with: 'HHHFn') with: FeEdition with: Position). table at: 126 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Edition.U.withoutAll.U.N2:with: with: 'HHHFn') with: FeEdition with: XnRegion). "Requests for class IDHolder" table at: 338 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #IDHolder.U.make.U.N1: with: 'HHFn') with: ID). table at: 339 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #IDHolder.U.iD.U.N1: with: 'HHFn') with: FeIDHolder). "Requests for class Label" table at: 340 storeValue: (HHandler make: (RequestHandler pointerToStaticMember: #Label.U.make.U.N0 with: 'HFn')). "Requests for class Work" table at: 127 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Work.U.make.U.N1: with: 'HHFn') with: FeEdition). table at: 128 storeValue: (BHHandler make: (RequestHandler pointerToStaticMember: #Work.U.canRead.U.N1: with: 'BHFn') with: FeWork). table at: 129 storeValue: (BHHandler make: (RequestHandler pointerToStaticMember: #Work.U.canRevise.U.N1: with: 'BHFn') with: FeWork). table at: 130 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Work.U.editClub.U.N1: with: 'HHFn') with: FeWork). table at: 131 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Work.U.edition.U.N1: with: 'HHFn') with: FeWork). table at: 341 storeValue: (VHHHandler make: (RequestHandler pointerToStaticMember: #Work.U.endorse.U.N2:with: with: 'VHHFn') with: FeWork with: CrossRegion). table at: 132 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Work.U.endorsements.U.N1: with: 'HHFn') with: FeWork). table at: 133 storeValue: (VHHandler make: (RequestHandler pointerToStaticMember: #Work.U.grab.U.N1: with: 'VHFn') with: FeWork). table at: 342 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Work.U.grabber.U.N1: with: 'HHFn') with: FeWork). table at: 343 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Work.U.historyClub.U.N1: with: 'HHFn') with: FeWork). table at: 134 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Work.U.lastRevisionAuthor.U.N1: with: 'HHFn') with: FeWork). table at: 344 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Work.U.lastRevisionNumber.U.N1: with: 'HHFn') with: FeWork). table at: 135 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Work.U.lastRevisionTime.U.N1: with: 'HHFn') with: FeWork). table at: 136 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Work.U.readClub.U.N1: with: 'HHFn') with: FeWork). table at: 137 storeValue: (VHHandler make: (RequestHandler pointerToStaticMember: #Work.U.release.U.N1: with: 'VHFn') with: FeWork). table at: 345 storeValue: (VHHandler make: (RequestHandler pointerToStaticMember: #Work.U.removeEditClub.U.N1: with: 'VHFn') with: FeWork). table at: 346 storeValue: (VHHandler make: (RequestHandler pointerToStaticMember: #Work.U.removeReadClub.U.N1: with: 'VHFn') with: FeWork). table at: 138 storeValue: (VHHandler make: (RequestHandler pointerToStaticMember: #Work.U.requestGrab.U.N1: with: 'VHFn') with: FeWork). table at: 347 storeValue: (VHHHandler make: (RequestHandler pointerToStaticMember: #Work.U.retract.U.N2:with: with: 'VHHFn') with: FeWork with: CrossRegion). table at: 139 storeValue: (VHHHandler make: (RequestHandler pointerToStaticMember: #Work.U.revise.U.N2:with: with: 'VHHFn') with: FeWork with: FeEdition). table at: 348 storeValue: (SpecialHandler make: (PromiseManager pointerToStaticMember: #revisionDetector: with: 'VHFn')). table at: 349 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Work.U.revisions.U.N1: with: 'HHFn') with: FeWork). table at: 350 storeValue: (VHHHandler make: (RequestHandler pointerToStaticMember: #Work.U.setEditClub.U.N2:with: with: 'VHHFn') with: FeWork with: ID). table at: 351 storeValue: (VHHHandler make: (RequestHandler pointerToStaticMember: #Work.U.setHistoryClub.U.N2:with: with: 'VHHFn') with: FeWork with: ID). table at: 352 storeValue: (VHHHandler make: (RequestHandler pointerToStaticMember: #Work.U.setReadClub.U.N2:with: with: 'VHHFn') with: FeWork with: ID). table at: 353 storeValue: (VHHHandler make: (RequestHandler pointerToStaticMember: #Work.U.sponsor.U.N2:with: with: 'VHHFn') with: FeWork with: IDRegion). table at: 354 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Work.U.sponsors.U.N1: with: 'HHFn') with: FeWork). table at: 355 storeValue: (SpecialHandler make: (PromiseManager pointerToStaticMember: #statusDetector: with: 'VHFn')). table at: 356 storeValue: (VHHHandler make: (RequestHandler pointerToStaticMember: #Work.U.unsponsor.U.N2:with: with: 'VHHFn') with: FeWork with: IDRegion). "Requests for class Club" table at: 357 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Club.U.make.U.N1: with: 'HHFn') with: FeEdition). table at: 358 storeValue: (VHHandler make: (RequestHandler pointerToStaticMember: #Club.U.removeSignatureClub.U.N1: with: 'VHFn') with: FeClub). table at: 359 storeValue: (VHHHandler make: (RequestHandler pointerToStaticMember: #Club.U.setSignatureClub.U.N2:with: with: 'VHHFn') with: FeClub with: ID). table at: 360 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Club.U.signatureClub.U.N1: with: 'HHFn') with: FeClub). table at: 361 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Club.U.sponsoredWorks.U.N1: with: 'HHFn') with: FeClub). table at: 362 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Club.U.sponsoredWorks.U.N2:with: with: 'HHHFn') with: FeClub with: Filter). "Requests for class RevisionDetector" "Requests for class Server" table at: 438 storeValue: (HHandler make: (RequestHandler pointerToStaticMember: #Server.U.accessClubID.U.N0 with: 'HFn')). table at: 439 storeValue: (HHandler make: (RequestHandler pointerToStaticMember: #Server.U.adminClubID.U.N0 with: 'HFn')). table at: 440 storeValue: (HHandler make: (RequestHandler pointerToStaticMember: #Server.U.archiveClubID.U.N0 with: 'HFn')). table at: 363 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Server.U.assignID.U.N1: with: 'HHFn') with: FeRangeElement). table at: 364 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Server.U.assignID.U.N2:with: with: 'HHHFn') with: FeRangeElement with: ID). table at: 441 storeValue: (HHandler make: (RequestHandler pointerToStaticMember: #Server.U.clubDirectoryID.U.N0 with: 'HFn')). table at: 365 storeValue: (HHandler make: (RequestHandler pointerToStaticMember: #Server.U.currentTime.U.N0 with: 'HFn')). table at: 442 storeValue: (HHandler make: (RequestHandler pointerToStaticMember: #Server.U.encrypterName.U.N0 with: 'HFn')). table at: 140 storeValue: (SpecialHandler make: (PromiseManager pointerToStaticMember: #forceIt: with: 'VHFn')). table at: 141 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Server.U.get.U.N1: with: 'HHFn') with: ID). table at: 443 storeValue: (HHandler make: (RequestHandler pointerToStaticMember: #Server.U.identifier.U.N0 with: 'HFn')). table at: 142 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Server.U.iDOf.U.N1: with: 'HHFn') with: FeRangeElement). table at: 143 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Server.U.iDsOf.U.N1: with: 'HHFn') with: FeRangeElement). table at: 144 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Server.U.iDsOfRange.U.N1: with: 'HHFn') with: FeEdition). table at: 444 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Server.U.login.U.N1: with: 'HHFn') with: ID). table at: 445 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Server.U.loginByName.U.N1: with: 'HHFn') with: Sequence). table at: 446 storeValue: (HHandler make: (RequestHandler pointerToStaticMember: #Server.U.emptyClubID.U.N0 with: 'HFn')). table at: 447 storeValue: (HHandler make: (RequestHandler pointerToStaticMember: #Server.U.publicClubID.U.N0 with: 'HFn')). table at: 448 storeValue: (HHandler make: (RequestHandler pointerToStaticMember: #Server.U.publicKey.U.N0 with: 'HFn')). table at: 145 storeValue: (SpecialHandler make: (PromiseManager pointerToStaticMember: #setCurrentAuthor: with: 'VHFn')). table at: 146 storeValue: (SpecialHandler make: (PromiseManager pointerToStaticMember: #setCurrentKeyMaster: with: 'VHFn')). table at: 147 storeValue: (SpecialHandler make: (PromiseManager pointerToStaticMember: #setInitialEditClub: with: 'VHFn')). table at: 148 storeValue: (SpecialHandler make: (PromiseManager pointerToStaticMember: #setInitialOwner: with: 'VHFn')). table at: 149 storeValue: (SpecialHandler make: (PromiseManager pointerToStaticMember: #setInitialReadClub: with: 'VHFn')). table at: 150 storeValue: (SpecialHandler make: (PromiseManager pointerToStaticMember: #setInitialSponsor: with: 'VHFn')). table at: 366 storeValue: (SpecialHandler make: (PromiseManager pointerToStaticMember: #waitForConsequences: with: 'VHFn')). table at: 367 storeValue: (SpecialHandler make: (PromiseManager pointerToStaticMember: #waitForWrite: with: 'VHFn')). "Requests for class Session" table at: 449 storeValue: (HHandler make: (RequestHandler pointerToStaticMember: #Session.U.current.U.N0 with: 'HFn')). table at: 450 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Session.U.connectTime.U.N1: with: 'HHFn') with: FeSession). table at: 451 storeValue: (VHHandler make: (RequestHandler pointerToStaticMember: #Session.U.endSession.U.N1: with: 'VHFn') with: FeSession). table at: 452 storeValue: (VHBHandler make: (RequestHandler pointerToStaticMember: #Session.U.endSession.U.N2:with: with: 'VHBFn') with: FeSession). table at: 453 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Session.U.initialLogin.U.N1: with: 'HHFn') with: FeSession). table at: 454 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Session.U.port.U.N1: with: 'HHFn') with: FeSession). table at: 470 storeValue: (BHHandler make: (RequestHandler pointerToStaticMember: #Session.U.isConnected.U.N1: with: 'BHFn') with: FeSession). "Requests for class StatusDetector" "Requests for class Stepper" table at: 151 storeValue: (BHHandler make: (RequestHandler pointerToStaticMember: #Stepper.U.atEnd.U.N1: with: 'BHFn') with: Stepper). table at: 254 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Stepper.U.copy.U.N1: with: 'HHFn') with: Stepper). table at: 152 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Stepper.U.get.U.N1: with: 'HHFn') with: Stepper). table at: 153 storeValue: (VHHandler make: (RequestHandler pointerToStaticMember: #Stepper.U.step.U.N1: with: 'VHFn') with: Stepper). table at: 154 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Stepper.U.stepMany.U.N1: with: 'HHFn') with: Stepper). self fillRequestTable4: table.! {void} fillRequestTable4: table {PtrArray} table at: 155 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Stepper.U.stepMany.U.N2:with: with: 'HHHFn') with: Stepper with: PrimIntValue). table at: 156 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Stepper.U.theOne.U.N1: with: 'HHFn') with: Stepper). "Requests for class TableStepper" table at: 157 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #TableStepper.U.position.U.N1: with: 'HHFn') with: TableStepper). table at: 158 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #TableStepper.U.stepManyPairs.U.N1: with: 'HHFn') with: TableStepper). table at: 159 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #TableStepper.U.stepManyPairs.U.N2:with: with: 'HHHFn') with: TableStepper with: PrimIntValue). "Requests for class Void" "Requests for class WaitDetector" "Requests for class Wrapper" table at: 160 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Wrapper.U.edition.U.N1: with: 'HHFn') with: FeWrapper). table at: 368 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Wrapper.U.inner.U.N1: with: 'HHFn') with: FeWrapper). "Requests for class ClubDescription" table at: 369 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #ClubDescription.U.make.U.N2:with: with: 'HHHFn') with: FeSet with: FeLockSmith). table at: 370 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #ClubDescription.U.lockSmith.U.N1: with: 'HHFn') with: FeClubDescription). table at: 371 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #ClubDescription.U.membership.U.N1: with: 'HHFn') with: FeClubDescription). table at: 372 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #ClubDescription.U.withLockSmith.U.N2:with: with: 'HHHFn') with: FeClubDescription with: FeLockSmith). table at: 373 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #ClubDescription.U.withMembership.U.N2:with: with: 'HHHFn') with: FeClubDescription with: FeSet). "Requests for class HyperLink" table at: 161 storeValue: (HHHHHandler make: (RequestHandler pointerToStaticMember: #HyperLink.U.make.U.N3:with:with: with: 'HHHHFn') with: FeSet with: FeHyperRef with: FeHyperRef). table at: 162 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #HyperLink.U.endAt.U.N2:with: with: 'HHHFn') with: FeHyperLink with: Sequence). table at: 163 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #HyperLink.U.endNames.U.N1: with: 'HHFn') with: FeHyperLink). table at: 164 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #HyperLink.U.linkTypes.U.N1: with: 'HHFn') with: FeHyperLink). table at: 165 storeValue: (HHHHHandler make: (RequestHandler pointerToStaticMember: #HyperLink.U.withEnd.U.N3:with:with: with: 'HHHHFn') with: FeHyperLink with: Sequence with: FeHyperRef). table at: 374 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #HyperLink.U.withLinkTypes.U.N2:with: with: 'HHHFn') with: FeHyperLink with: FeSet). table at: 375 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #HyperLink.U.withoutEnd.U.N2:with: with: 'HHHFn') with: FeHyperLink with: Sequence). "Requests for class HyperRef" table at: 166 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #HyperRef.U.originalContext.U.N1: with: 'HHFn') with: FeHyperRef). table at: 167 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #HyperRef.U.pathContext.U.N1: with: 'HHFn') with: FeHyperRef). table at: 376 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #HyperRef.U.withOriginalContext.U.N2:with: with: 'HHHFn') with: FeHyperRef with: FeWork). table at: 377 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #HyperRef.U.withPathContext.U.N2:with: with: 'HHHFn') with: FeHyperRef with: FePath). table at: 378 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #HyperRef.U.withWorkContext.U.N2:with: with: 'HHHFn') with: FeHyperRef with: FeWork). table at: 168 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #HyperRef.U.workContext.U.N1: with: 'HHFn') with: FeHyperRef). "Requests for class MultiRef" table at: 169 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #MultiRef.U.make.U.N1: with: 'HHFn') with: PtrArray). table at: 170 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #MultiRef.U.make.U.N2:with: with: 'HHHFn') with: PtrArray with: FeWork). table at: 171 storeValue: (HHHHHandler make: (RequestHandler pointerToStaticMember: #MultiRef.U.make.U.N3:with:with: with: 'HHHHFn') with: PtrArray with: FeWork with: FeWork). table at: 172 storeValue: (HHHHHHandler make: (RequestHandler pointerToStaticMember: #MultiRef.U.make.U.N4:with:with:with: with: 'HHHHHFn') with: PtrArray with: FeWork with: FeWork with: FePath). table at: 379 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #MultiRef.U.intersect.U.N2:with: with: 'HHHFn') with: FeMultiRef with: FeMultiRef). table at: 380 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #MultiRef.U.minus.U.N2:with: with: 'HHHFn') with: FeMultiRef with: FeMultiRef). table at: 173 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #MultiRef.U.refs.U.N1: with: 'HHFn') with: FeMultiRef). table at: 381 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #MultiRef.U.unionWith.U.N2:with: with: 'HHHFn') with: FeMultiRef with: FeMultiRef). table at: 382 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #MultiRef.U.with.U.N2:with: with: 'HHHFn') with: FeMultiRef with: FeHyperRef). table at: 383 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #MultiRef.U.without.U.N2:with: with: 'HHHFn') with: FeMultiRef with: FeHyperRef). "Requests for class SingleRef" table at: 174 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #SingleRef.U.make.U.N1: with: 'HHFn') with: FeEdition). table at: 175 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #SingleRef.U.make.U.N2:with: with: 'HHHFn') with: FeEdition with: FeWork). table at: 176 storeValue: (HHHHHandler make: (RequestHandler pointerToStaticMember: #SingleRef.U.make.U.N3:with:with: with: 'HHHHFn') with: FeEdition with: FeWork with: FeWork). table at: 177 storeValue: (HHHHHHandler make: (RequestHandler pointerToStaticMember: #SingleRef.U.make.U.N4:with:with:with: with: 'HHHHHFn') with: FeEdition with: FeWork with: FeWork with: FePath). table at: 178 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #SingleRef.U.excerpt.U.N1: with: 'HHFn') with: FeSingleRef). table at: 384 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #SingleRef.U.withExcerpt.U.N2:with: with: 'HHHFn') with: FeSingleRef with: FeEdition). "Requests for class LockSmith" "Requests for class BooLockSmith" table at: 455 storeValue: (HHandler make: (RequestHandler pointerToStaticMember: #BooLockSmith.U.make.U.N0 with: 'HFn')). "Requests for class ChallengeLockSmith" table at: 456 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #ChallengeLockSmith.U.make.U.N2:with: with: 'HHHFn') with: PrimIntArray with: Sequence). table at: 457 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #ChallengeLockSmith.U.encrypterName.U.N1: with: 'HHFn') with: FeChallengeLockSmith). table at: 458 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #ChallengeLockSmith.U.publicKey.U.N1: with: 'HHFn') with: FeChallengeLockSmith). "Requests for class MatchLockSmith" table at: 459 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #MatchLockSmith.U.make.U.N2:with: with: 'HHHFn') with: PrimIntArray with: Sequence). table at: 460 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #MatchLockSmith.U.scrambledPassword.U.N1: with: 'HHFn') with: FeMatchLockSmith). table at: 461 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #MatchLockSmith.U.scramblerName.U.N1: with: 'HHFn') with: FeMatchLockSmith). "Requests for class MultiLockSmith" table at: 462 storeValue: (HHandler make: (RequestHandler pointerToStaticMember: #MultiLockSmith.U.make.U.N0 with: 'HFn')). table at: 463 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #MultiLockSmith.U.lockSmith.U.N2:with: with: 'HHHFn') with: FeMultiLockSmith with: Sequence). table at: 464 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #MultiLockSmith.U.lockSmithNames.U.N1: with: 'HHFn') with: FeMultiLockSmith). table at: 465 storeValue: (HHHHHandler make: (RequestHandler pointerToStaticMember: #MultiLockSmith.U.with.U.N3:with:with: with: 'HHHHFn') with: FeMultiLockSmith with: Sequence with: FeLockSmith). table at: 466 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #MultiLockSmith.U.without.U.N2:with: with: 'HHHFn') with: FeMultiLockSmith with: Sequence). "Requests for class WallLockSmith" table at: 467 storeValue: (HHandler make: (RequestHandler pointerToStaticMember: #WallLockSmith.U.make.U.N0 with: 'HFn')). "Requests for class Path" table at: 179 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Path.U.make.U.N1: with: 'HHFn') with: PtrArray). table at: 180 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Path.U.follow.U.N2:with: with: 'HHHFn') with: FePath with: FeEdition). "Requests for class Set" table at: 181 storeValue: (HHandler make: (RequestHandler pointerToStaticMember: #Set.U.make.U.N0 with: 'HFn')). table at: 182 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Set.U.make.U.N1: with: 'HHFn') with: PtrArray). table at: 183 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Set.U.count.U.N1: with: 'HHFn') with: FeSet). table at: 184 storeValue: (BHHHandler make: (RequestHandler pointerToStaticMember: #Set.U.includes.U.N2:with: with: 'BHHFn') with: FeSet with: FeRangeElement). table at: 385 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Set.U.intersect.U.N2:with: with: 'HHHFn') with: FeSet with: FeSet). table at: 386 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Set.U.minus.U.N2:with: with: 'HHHFn') with: FeSet with: FeSet). table at: 185 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Set.U.theOne.U.N1: with: 'HHFn') with: FeSet). table at: 387 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Set.U.unionWith.U.N2:with: with: 'HHHFn') with: FeSet with: FeSet). table at: 388 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Set.U.with.U.N2:with: with: 'HHHFn') with: FeSet with: FeRangeElement). table at: 389 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Set.U.without.U.N2:with: with: 'HHHFn') with: FeSet with: FeRangeElement). "Requests for class Text" table at: 186 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Text.U.make.U.N1: with: 'HHFn') with: PrimArray). table at: 187 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Text.U.contents.U.N1: with: 'HHFn') with: FeText). table at: 188 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Text.U.count.U.N1: with: 'HHFn') with: FeText). table at: 189 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Text.U.extract.U.N2:with: with: 'HHHFn') with: FeText with: IntegerRegion). table at: 190 storeValue: (HHHHHandler make: (RequestHandler pointerToStaticMember: #Text.U.insert.U.N3:with:with: with: 'HHHHFn') with: FeText with: PrimIntValue with: FeText). table at: 191 storeValue: (HHHHHandler make: (RequestHandler pointerToStaticMember: #Text.U.move.U.N3:with:with: with: 'HHHHFn') with: FeText with: PrimIntValue with: IntegerRegion). table at: 192 storeValue: (HHHHHandler make: (RequestHandler pointerToStaticMember: #Text.U.replace.U.N3:with:with: with: 'HHHHFn') with: FeText with: IntegerRegion with: FeText). "Requests for class WrapperSpec" table at: 193 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #WrapperSpec.U.get.U.N1: with: 'HHFn') with: Sequence). table at: 194 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #WrapperSpec.U.filter.U.N1: with: 'HHFn') with: FeWrapperSpec). table at: 390 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #WrapperSpec.U.name.U.N1: with: 'HHFn') with: FeWrapperSpec). table at: 195 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #WrapperSpec.U.wrap.U.N2:with: with: 'HHHFn') with: FeWrapperSpec with: FeEdition). "Requests for class Region" table at: 196 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Region.U.chooseMany.U.N2:with: with: 'HHHFn') with: XnRegion with: PrimIntValue). table at: 197 storeValue: (HHHHHandler make: (RequestHandler pointerToStaticMember: #Region.U.chooseMany.U.N3:with:with: with: 'HHHHFn') with: XnRegion with: PrimIntValue with: OrderSpec). table at: 198 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Region.U.chooseOne.U.N1: with: 'HHFn') with: XnRegion). self fillRequestTable5: table.! {void} fillRequestTable5: table {PtrArray} table at: 199 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Region.U.chooseOne.U.N2:with: with: 'HHHFn') with: XnRegion with: OrderSpec). table at: 200 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Region.U.complement.U.N1: with: 'HHFn') with: XnRegion). table at: 201 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Region.U.coordinateSpace.U.N1: with: 'HHFn') with: XnRegion). table at: 202 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Region.U.count.U.N1: with: 'HHFn') with: XnRegion). table at: 203 storeValue: (BHHHandler make: (RequestHandler pointerToStaticMember: #Region.U.hasMember.U.N2:with: with: 'BHHFn') with: XnRegion with: Position). table at: 204 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Region.U.intersect.U.N2:with: with: 'HHHFn') with: XnRegion with: XnRegion). table at: 205 storeValue: (BHHHandler make: (RequestHandler pointerToStaticMember: #Region.U.intersects.U.N2:with: with: 'BHHFn') with: XnRegion with: XnRegion). table at: 206 storeValue: (BHHandler make: (RequestHandler pointerToStaticMember: #Region.U.isEmpty.U.N1: with: 'BHFn') with: XnRegion). table at: 207 storeValue: (BHHandler make: (RequestHandler pointerToStaticMember: #Region.U.isFinite.U.N1: with: 'BHFn') with: XnRegion). table at: 208 storeValue: (BHHandler make: (RequestHandler pointerToStaticMember: #Region.U.isFull.U.N1: with: 'BHFn') with: XnRegion). table at: 209 storeValue: (BHHHandler make: (RequestHandler pointerToStaticMember: #Region.U.isSubsetOf.U.N2:with: with: 'BHHFn') with: XnRegion with: XnRegion). table at: 210 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Region.U.minus.U.N2:with: with: 'HHHFn') with: XnRegion with: XnRegion). table at: 211 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Region.U.stepper.U.N1: with: 'HHFn') with: XnRegion). table at: 212 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Region.U.stepper.U.N2:with: with: 'HHHFn') with: XnRegion with: OrderSpec). table at: 213 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Region.U.theOne.U.N1: with: 'HHFn') with: XnRegion). table at: 214 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Region.U.unionWith.U.N2:with: with: 'HHHFn') with: XnRegion with: XnRegion). table at: 215 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Region.U.with.U.N2:with: with: 'HHHFn') with: XnRegion with: Position). table at: 216 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Region.U.without.U.N2:with: with: 'HHHFn') with: XnRegion with: Position). "Requests for class CrossRegion" table at: 217 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #CrossRegion.U.boxes.U.N1: with: 'HHFn') with: CrossRegion). table at: 218 storeValue: (BHHandler make: (RequestHandler pointerToStaticMember: #CrossRegion.U.isBox.U.N1: with: 'BHFn') with: CrossRegion). table at: 219 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #CrossRegion.U.projection.U.N2:with: with: 'HHHFn') with: CrossRegion with: PrimIntValue). table at: 220 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #CrossRegion.U.projections.U.N1: with: 'HHFn') with: CrossRegion). "Requests for class Filter" table at: 391 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Filter.U.baseRegion.U.N1: with: 'HHFn') with: Filter). table at: 392 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Filter.U.intersectedFilters.U.N1: with: 'HHFn') with: Filter). table at: 393 storeValue: (BHHandler make: (RequestHandler pointerToStaticMember: #Filter.U.isAllFilter.U.N1: with: 'BHFn') with: Filter). table at: 394 storeValue: (BHHandler make: (RequestHandler pointerToStaticMember: #Filter.U.isAnyFilter.U.N1: with: 'BHFn') with: Filter). table at: 221 storeValue: (BHHHandler make: (RequestHandler pointerToStaticMember: #Filter.U.match.U.N2:with: with: 'BHHFn') with: Filter with: XnRegion). table at: 395 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Filter.U.unionedFilters.U.N1: with: 'HHFn') with: Filter). "Requests for class IDRegion" table at: 396 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #IDRegion.U.import.U.N1: with: 'HHFn') with: PrimIntArray). table at: 397 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #IDRegion.U.export.U.N1: with: 'HHFn') with: IDRegion). "Requests for class IntegerRegion" table at: 222 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #IntegerRegion.U.intervals.U.N1: with: 'HHFn') with: IntegerRegion). table at: 398 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #IntegerRegion.U.intervals.U.N2:with: with: 'HHHFn') with: IntegerRegion with: OrderSpec). table at: 223 storeValue: (BHHandler make: (RequestHandler pointerToStaticMember: #IntegerRegion.U.isBoundedAbove.U.N1: with: 'BHFn') with: IntegerRegion). table at: 224 storeValue: (BHHandler make: (RequestHandler pointerToStaticMember: #IntegerRegion.U.isBoundedBelow.U.N1: with: 'BHFn') with: IntegerRegion). table at: 225 storeValue: (BHHandler make: (RequestHandler pointerToStaticMember: #IntegerRegion.U.isInterval.U.N1: with: 'BHFn') with: IntegerRegion). table at: 226 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #IntegerRegion.U.start.U.N1: with: 'HHFn') with: IntegerRegion). table at: 227 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #IntegerRegion.U.stop.U.N1: with: 'HHFn') with: IntegerRegion). "Requests for class RealRegion" table at: 228 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #RealRegion.U.intervals.U.N1: with: 'HHFn') with: RealRegion). table at: 399 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #RealRegion.U.intervals.U.N2:with: with: 'HHHFn') with: RealRegion with: OrderSpec). table at: 229 storeValue: (BHHandler make: (RequestHandler pointerToStaticMember: #RealRegion.U.isBoundedAbove.U.N1: with: 'BHFn') with: RealRegion). table at: 230 storeValue: (BHHandler make: (RequestHandler pointerToStaticMember: #RealRegion.U.isBoundedBelow.U.N1: with: 'BHFn') with: RealRegion). table at: 231 storeValue: (BHHandler make: (RequestHandler pointerToStaticMember: #RealRegion.U.isInterval.U.N1: with: 'BHFn') with: RealRegion). table at: 232 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #RealRegion.U.lowerBound.U.N1: with: 'HHFn') with: RealRegion). table at: 233 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #RealRegion.U.upperBound.U.N1: with: 'HHFn') with: RealRegion). "Requests for class SequenceRegion" table at: 234 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #SequenceRegion.U.intervals.U.N1: with: 'HHFn') with: SequenceRegion). table at: 400 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #SequenceRegion.U.intervals.U.N2:with: with: 'HHHFn') with: SequenceRegion with: OrderSpec). table at: 235 storeValue: (BHHandler make: (RequestHandler pointerToStaticMember: #SequenceRegion.U.isBoundedAbove.U.N1: with: 'BHFn') with: SequenceRegion). table at: 236 storeValue: (BHHandler make: (RequestHandler pointerToStaticMember: #SequenceRegion.U.isBoundedBelow.U.N1: with: 'BHFn') with: SequenceRegion). table at: 237 storeValue: (BHHandler make: (RequestHandler pointerToStaticMember: #SequenceRegion.U.isInterval.U.N1: with: 'BHFn') with: SequenceRegion). table at: 238 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #SequenceRegion.U.lowerEdge.U.N1: with: 'HHFn') with: SequenceRegion). table at: 239 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #SequenceRegion.U.lowerEdgePrefixLimit.U.N1: with: 'HHFn') with: SequenceRegion). table at: 240 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #SequenceRegion.U.lowerEdgeType.U.N1: with: 'HHFn') with: SequenceRegion). table at: 241 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #SequenceRegion.U.upperEdge.U.N1: with: 'HHFn') with: SequenceRegion). table at: 242 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #SequenceRegion.U.upperEdgePrefixLimit.U.N1: with: 'HHFn') with: SequenceRegion). table at: 243 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #SequenceRegion.U.upperEdgeType.U.N1: with: 'HHFn') with: SequenceRegion). "Requests for class Value" "Requests for class FloatValue" table at: 244 storeValue: (SpecialHandler make: (PromiseManager pointerToStaticMember: #makeFloat: with: 'VHFn')). table at: 401 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #FloatValue.U.bitCount.U.N1: with: 'HHFn') with: PrimFloatValue). "Requests for class IntValue" table at: 245 storeValue: (SpecialHandler make: (PromiseManager pointerToStaticMember: #makeHumber: with: 'VHFn')). table at: 402 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #IntValue.U.bitwiseAnd.U.N2:with: with: 'HHHFn') with: PrimIntValue with: PrimIntValue). table at: 403 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #IntValue.U.bitwiseOr.U.N2:with: with: 'HHHFn') with: PrimIntValue with: PrimIntValue). table at: 404 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #IntValue.U.bitwiseXor.U.N2:with: with: 'HHHFn') with: PrimIntValue with: PrimIntValue). table at: 246 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #IntValue.U.dividedBy.U.N2:with: with: 'HHHFn') with: PrimIntValue with: PrimIntValue). table at: 247 storeValue: (BHHHandler make: (RequestHandler pointerToStaticMember: #IntValue.U.isGE.U.N2:with: with: 'BHHFn') with: PrimIntValue with: PrimIntValue). table at: 405 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #IntValue.U.leftShift.U.N2:with: with: 'HHHFn') with: PrimIntValue with: PrimIntValue). table at: 248 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #IntValue.U.maximum.U.N2:with: with: 'HHHFn') with: PrimIntValue with: PrimIntValue). table at: 249 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #IntValue.U.minimum.U.N2:with: with: 'HHHFn') with: PrimIntValue with: PrimIntValue). table at: 250 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #IntValue.U.minus.U.N2:with: with: 'HHHFn') with: PrimIntValue with: PrimIntValue). table at: 406 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #IntValue.U.mod.U.N2:with: with: 'HHHFn') with: PrimIntValue with: PrimIntValue). table at: 251 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #IntValue.U.plus.U.N2:with: with: 'HHHFn') with: PrimIntValue with: PrimIntValue). table at: 407 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #IntValue.U.bitCount.U.N1: with: 'HHFn') with: PrimIntValue). table at: 252 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #IntValue.U.times.U.N2:with: with: 'HHHFn') with: PrimIntValue with: PrimIntValue).! {void} fillRequestTable: table {PtrArray} "Requests for class Promise" table at: 253 storeValue: (SpecialHandler make: (PromiseManager pointerToStaticMember: #waiveEm: with: 'VHFn')). table at: 1 storeValue: (SpecialHandler make: (PromiseManager pointerToStaticMember: #delayCast: with: 'VHFn')). table at: 2 storeValue: (SpecialHandler make: (PromiseManager pointerToStaticMember: #equals: with: 'VHFn')). table at: 3 storeValue: (SpecialHandler make: (PromiseManager pointerToStaticMember: #promiseHash: with: 'VHFn')). table at: 4 storeValue: (SpecialHandler make: (PromiseManager pointerToStaticMember: #testKindOf: with: 'VHFn')). table at: 5 storeValue: (SpecialHandler make: (PromiseManager pointerToStaticMember: #waiveIt: with: 'VHFn')). "Requests for class Adminer" table at: 408 storeValue: (HHandler make: (RequestHandler pointerToStaticMember: #Adminer.U.make.U.N0 with: 'HFn')). table at: 409 storeValue: (VHBHandler make: (RequestHandler pointerToStaticMember: #Adminer.U.acceptConnections.U.N2:with: with: 'VHBFn') with: FeAdminer). table at: 410 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Adminer.U.activeSessions.U.N1: with: 'HHFn') with: FeAdminer). table at: 411 storeValue: (VHHHandler make: (RequestHandler pointerToStaticMember: #Adminer.U.execute.U.N2:with: with: 'VHHFn') with: FeAdminer with: PrimIntArray). table at: 412 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Adminer.U.gateLockSmith.U.N1: with: 'HHFn') with: FeAdminer). table at: 413 storeValue: (VHHHHandler make: (RequestHandler pointerToStaticMember: #Adminer.U.grant.U.N3:with:with: with: 'VHHHFn') with: FeAdminer with: ID with: IDRegion). table at: 414 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Adminer.U.grants.U.N1: with: 'HHFn') with: FeAdminer). table at: 415 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Adminer.U.grants.U.N2:with: with: 'HHHFn') with: FeAdminer with: IDRegion). table at: 416 storeValue: (HHHHHandler make: (RequestHandler pointerToStaticMember: #Adminer.U.grants.U.N3:with:with: with: 'HHHHFn') with: FeAdminer with: IDRegion with: IDRegion). table at: 417 storeValue: (BHHandler make: (RequestHandler pointerToStaticMember: #Adminer.U.isAcceptingConnections.U.N1: with: 'BHFn') with: FeAdminer). table at: 418 storeValue: (VHHHandler make: (RequestHandler pointerToStaticMember: #Adminer.U.setGateLockSmith.U.N2:with: with: 'VHHFn') with: FeAdminer with: FeLockSmith). table at: 419 storeValue: (SpecialHandler make: (PromiseManager pointerToStaticMember: #shutdown: with: 'VHFn')). "Requests for class Archiver" table at: 420 storeValue: (HHandler make: (RequestHandler pointerToStaticMember: #Archiver.U.make.U.N0 with: 'HFn')). table at: 421 storeValue: (HHHHHandler make: (RequestHandler pointerToStaticMember: #Archiver.U.archive.U.N3:with:with: with: 'HHHHFn') with: FeArchiver with: FeEdition with: FeEdition). table at: 422 storeValue: (VHHHandler make: (RequestHandler pointerToStaticMember: #Archiver.U.markArchived.U.N2:with: with: 'VHHFn') with: FeArchiver with: FeEdition). table at: 423 storeValue: (HHHHHandler make: (RequestHandler pointerToStaticMember: #Archiver.U.restore.U.N3:with:with: with: 'HHHHFn') with: FeArchiver with: FeEdition with: FeEdition). "Requests for class Array" table at: 468 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Array.U.copy.U.N1: with: 'HHFn') with: PrimArray). table at: 469 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Array.U.copy.U.N2:with: with: 'HHHFn') with: PrimArray with: PrimIntValue). table at: 255 storeValue: (HHHHHandler make: (RequestHandler pointerToStaticMember: #Array.U.copy.U.N3:with:with: with: 'HHHHFn') with: PrimArray with: PrimIntValue with: PrimIntValue). table at: 424 storeValue: (HHHHHHandler make: (RequestHandler pointerToStaticMember: #Array.U.copy.U.N4:with:with:with: with: 'HHHHHFn') with: PrimArray with: PrimIntValue with: PrimIntValue with: PrimIntValue). table at: 425 storeValue: (HHHHHHHandler make: (RequestHandler pointerToStaticMember: #Array.U.copy.U.N5:with:with:with:with: with: 'HHHHHHFn') with: PrimArray with: PrimIntValue with: PrimIntValue with: PrimIntValue with: PrimIntValue). table at: 6 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Array.U.count.U.N1: with: 'HHFn') with: PrimArray). table at: 7 storeValue: (SpecialHandler make: (PromiseManager pointerToStaticMember: #export0: with: 'VHFn')). table at: 256 storeValue: (SpecialHandler make: (PromiseManager pointerToStaticMember: #export1: with: 'VHFn')). table at: 257 storeValue: (SpecialHandler make: (PromiseManager pointerToStaticMember: #export2: with: 'VHFn')). table at: 8 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #Array.U.get.U.N2:with: with: 'HHHFn') with: PrimArray with: PrimIntValue). table at: 9 storeValue: (VHHHHandler make: (RequestHandler pointerToStaticMember: #Array.U.store.U.N3:with:with: with: 'VHHHFn') with: PrimArray with: PrimIntValue with: Heaper). table at: 258 storeValue: (VHHandler make: (RequestHandler pointerToStaticMember: #Array.U.storeAll.U.N1: with: 'VHFn') with: PrimArray). table at: 259 storeValue: (VHHHandler make: (RequestHandler pointerToStaticMember: #Array.U.storeAll.U.N2:with: with: 'VHHFn') with: PrimArray with: Heaper). table at: 260 storeValue: (VHHHHandler make: (RequestHandler pointerToStaticMember: #Array.U.storeAll.U.N3:with:with: with: 'VHHHFn') with: PrimArray with: Heaper with: PrimIntValue). table at: 261 storeValue: (VHHHHHandler make: (RequestHandler pointerToStaticMember: #Array.U.storeAll.U.N4:with:with:with: with: 'VHHHHFn') with: PrimArray with: Heaper with: PrimIntValue with: PrimIntValue). table at: 262 storeValue: (VHHHHandler make: (RequestHandler pointerToStaticMember: #Array.U.storeMany.U.N3:with:with: with: 'VHHHFn') with: PrimArray with: PrimIntValue with: PrimArray). table at: 263 storeValue: (VHHHHHandler make: (RequestHandler pointerToStaticMember: #Array.U.storeMany.U.N4:with:with:with: with: 'VHHHHFn') with: PrimArray with: PrimIntValue with: PrimArray with: PrimIntValue). table at: 264 storeValue: (VHHHHHHandler make: (RequestHandler pointerToStaticMember: #Array.U.storeMany.U.N5:with:with:with:with: with: 'VHHHHHFn') with: PrimArray with: PrimIntValue with: PrimArray with: PrimIntValue with: PrimIntValue). "Requests for class FloatArray" table at: 265 storeValue: (SpecialHandler make: (PromiseManager pointerToStaticMember: #makeFloatArray: with: 'VHFn')). table at: 266 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #FloatArray.U.zeros.U.N2:with: with: 'HHHFn') with: PrimIntValue with: PrimIntValue). table at: 267 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #FloatArray.U.bitCount.U.N1: with: 'HHFn') with: PrimFloatArray). "Requests for class HumberArray" table at: 268 storeValue: (SpecialHandler make: (PromiseManager pointerToStaticMember: #makeHumberArray: with: 'VHFn')). table at: 269 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #HumberArray.U.zeros.U.N1: with: 'HHFn') with: PrimIntValue). "Requests for class IntArray" table at: 10 storeValue: (SpecialHandler make: (PromiseManager pointerToStaticMember: #makeIntArray: with: 'VHFn')). table at: 11 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #IntArray.U.zeros.U.N2:with: with: 'HHHFn') with: PrimIntValue with: PrimIntValue). table at: 12 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #IntArray.U.bitCount.U.N1: with: 'HHFn') with: PrimIntArray). "Requests for class PtrArray" table at: 270 storeValue: (SpecialHandler make: (PromiseManager pointerToStaticMember: #makePtrArray: with: 'VHFn')). table at: 271 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #PtrArray.U.nulls.U.N1: with: 'HHFn') with: PrimIntValue). "Requests for class Bundle" table at: 13 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #Bundle.U.region.U.N1: with: 'HHFn') with: FeBundle). "Requests for class ArrayBundle" table at: 14 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #ArrayBundle.U.array.U.N1: with: 'HHFn') with: FeArrayBundle). table at: 15 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #ArrayBundle.U.ordering.U.N1: with: 'HHFn') with: FeArrayBundle). "Requests for class ElementBundle" table at: 16 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #ElementBundle.U.element.U.N1: with: 'HHFn') with: FeElementBundle). "Requests for class PlaceHolderBundle" "Requests for class CoordinateSpace" table at: 272 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #CoordinateSpace.U.ascending.U.N1: with: 'HHFn') with: CoordinateSpace). table at: 273 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #CoordinateSpace.U.completeMapping.U.N2:with: with: 'HHHFn') with: CoordinateSpace with: XnRegion). table at: 274 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #CoordinateSpace.U.descending.U.N1: with: 'HHFn') with: CoordinateSpace). table at: 17 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #CoordinateSpace.U.emptyRegion.U.N1: with: 'HHFn') with: CoordinateSpace). table at: 18 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #CoordinateSpace.U.fullRegion.U.N1: with: 'HHFn') with: CoordinateSpace). table at: 19 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #CoordinateSpace.U.identityMapping.U.N1: with: 'HHFn') with: CoordinateSpace). "Requests for class CrossSpace" table at: 20 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #CrossSpace.U.make.U.N1: with: 'HHFn') with: PtrArray). table at: 275 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #CrossSpace.U.axes.U.N1: with: 'HHFn') with: CrossSpace). table at: 276 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #CrossSpace.U.axis.U.N2:with: with: 'HHHFn') with: CrossSpace with: PrimIntValue). table at: 277 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #CrossSpace.U.axisCount.U.N1: with: 'HHFn') with: CrossSpace). table at: 278 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #CrossSpace.U.crossOfMappings.U.N1: with: 'HHFn') with: CrossSpace). table at: 279 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #CrossSpace.U.crossOfMappings.U.N2:with: with: 'HHHFn') with: CrossSpace with: PtrArray). table at: 426 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #CrossSpace.U.crossOfOrderSpecs.U.N1: with: 'HHFn') with: CrossSpace). table at: 427 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #CrossSpace.U.crossOfOrderSpecs.U.N2:with: with: 'HHHFn') with: CrossSpace with: PtrArray). table at: 428 storeValue: (HHHHHandler make: (RequestHandler pointerToStaticMember: #CrossSpace.U.crossOfOrderSpecs.U.N3:with:with: with: 'HHHHFn') with: CrossSpace with: PtrArray with: PrimIntArray). table at: 21 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #CrossSpace.U.crossOfPositions.U.N2:with: with: 'HHHFn') with: CrossSpace with: PtrArray). table at: 22 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #CrossSpace.U.crossOfRegions.U.N2:with: with: 'HHHFn') with: CrossSpace with: PtrArray). table at: 23 storeValue: (HHHHHandler make: (RequestHandler pointerToStaticMember: #CrossSpace.U.extrusion.U.N3:with:with: with: 'HHHHFn') with: CrossSpace with: PrimIntValue with: XnRegion). "Requests for class FilterSpace" table at: 280 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #FilterSpace.U.make.U.N1: with: 'HHFn') with: CoordinateSpace). table at: 24 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #FilterSpace.U.allFilter.U.N2:with: with: 'HHHFn') with: FilterSpace with: XnRegion). table at: 25 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #FilterSpace.U.anyFilter.U.N2:with: with: 'HHHFn') with: FilterSpace with: XnRegion). table at: 281 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #FilterSpace.U.baseSpace.U.N1: with: 'HHFn') with: FilterSpace). table at: 429 storeValue: (HHHHandler make: (RequestHandler pointerToStaticMember: #FilterSpace.U.position.U.N2:with: with: 'HHHFn') with: FilterSpace with: XnRegion). "Requests for class IDSpace" table at: 26 storeValue: (HHandler make: (RequestHandler pointerToStaticMember: #IDSpace.U.global.U.N0 with: 'HFn')). table at: 282 storeValue: (HHHandler make: (RequestHandler pointerToStaticMember: #IDSpace.U.import.U.N1: with: 'HHFn') with: PrimIntArray). self fillRequestTable1: table.! !Heaper subclass: #Prop instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Canopy-Prop'! Prop comment: 'A collection of properties which are to be found by navigating a Canopy. PropJoints are the union/intersection style abstraction of the properties which provide for such navigation.'! (Prop getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !Prop methodsFor: 'accessing'! {UInt32} flags "The flags used in the Canopy to tag this prop" self subclassResponsibility! {Prop} with: other {Prop} self subclassResponsibility! ! !Prop methodsFor: 'smalltalk: suspended'! {PropJoint} joint "Returns the filtering information from this one prop as a PropJoint. " self subclassResponsibility! ! !Prop methodsFor: 'tesing'! {UInt32} actualHashForEqual ^Heaper takeOop! !Prop subclass: #BertProp instanceVariableNames: ' myPermissions {XnRegion of: ID} myEndorsements {XnRegion of: ID} mySensorWaitingFlag {BooleanVar} myCannotPartializeFlag {BooleanVar}' classVariableNames: 'TheIdentityBertProp {BertProp} ' poolDictionaries: '' category: 'Xanadu-Be-Canopy-Prop'! BertProp comment: 'The properties which are nevigable towards using the Bert Canopy. All of these are properties of the Stamps at the leaves of the Bert Canopy.'! (BertProp getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !BertProp methodsFor: 'accessing'! {CrossRegion} endorsements ^myEndorsements cast: CrossRegion! {UInt32} flags ^BertCrum flagsFor: (myPermissions cast: IDRegion) with: (myEndorsements cast: CrossRegion) with: myCannotPartializeFlag with: mySensorWaitingFlag! {BooleanVar} isNotPartializable ^myCannotPartializeFlag! {BooleanVar} isSensorWaiting ^mySensorWaitingFlag! {XnRegion of: ID} permissions ^myPermissions! {Prop} with: other {Prop} | o {BertProp} | o _ other cast: BertProp. ^BertProp make: (myPermissions unionWith: o permissions) with: (myEndorsements unionWith: o endorsements) with: (mySensorWaitingFlag or: [o isSensorWaiting]) with: (myCannotPartializeFlag or: [o isNotPartializable])! ! !BertProp methodsFor: 'creation'! create: permissions {XnRegion of: ID} with: endorsements {XnRegion of: ID} with: isSensorWaiting {BooleanVar} with: isNotPartializable {BooleanVar} super create. myPermissions _ permissions. myEndorsements _ endorsements. mySensorWaitingFlag _ isSensorWaiting. myCannotPartializeFlag _ isNotPartializable.! ! !BertProp methodsFor: 'testing'! {UInt32} actualHashForEqual ^myPermissions hashForEqual bitXor: myEndorsements hashForEqual! {BooleanVar} isEmpty "Does this do the right thing." self knownBug. ^myEndorsements isEmpty and: [myPermissions isEmpty]! {BooleanVar} isEqual: other {Heaper} other cast: BertProp into: [:b | ^(b endorsements isEqual: myEndorsements) and: [(b permissions isEqual: myPermissions) and: [b isSensorWaiting == mySensorWaitingFlag and: [b isNotPartializable == myCannotPartializeFlag]]]] others: [^false]. ^ false "compiler fodder"! ! !BertProp methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '(P: ' << myPermissions << '; E: ' << myEndorsements. mySensorWaitingFlag ifTrue: [oo << '; sensor']. myCannotPartializeFlag ifTrue: [oo << '; cannot partialize']. oo << ')'! ! !BertProp methodsFor: 'smalltalk: suspended'! {PropJoint} joint ^BertPropJoint make: (Joint make: myPermissions) with: (Joint make: myEndorsements) with: mySensorWaitingFlag with: myCannotPartializeFlag! ! !BertProp methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myPermissions _ receiver receiveHeaper. myEndorsements _ receiver receiveHeaper. mySensorWaitingFlag _ receiver receiveBooleanVar. myCannotPartializeFlag _ receiver receiveBooleanVar.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myPermissions. xmtr sendHeaper: myEndorsements. xmtr sendBooleanVar: mySensorWaitingFlag. xmtr sendBooleanVar: myCannotPartializeFlag.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BertProp class instanceVariableNames: ''! (BertProp getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !BertProp class methodsFor: 'creation'! {BertProp} cannotPartializeProp [BeGrandMap] USES. ^BertProp make: IDSpace global emptyRegion with: CurrentGrandMap fluidGet endorsementSpace emptyRegion with: false with: true! {BertProp} detectorWaitingProp ^BertProp make: CurrentGrandMap fluidGet globalIDSpace emptyRegion with: CurrentGrandMap fluidGet endorsementSpace emptyRegion with: true with: false! {BertProp} endorsementsProp: endorsements {XnRegion} ^BertProp make: IDSpace global emptyRegion with: endorsements with: false with: false! {BertProp} make TheIdentityBertProp == NULL ifTrue: [TheIdentityBertProp := BertProp make: IDSpace global emptyRegion with: CurrentGrandMap fluidGet endorsementSpace emptyRegion with: false with: false]. ^TheIdentityBertProp! make: permissions {XnRegion of: ID} with: endorsements {XnRegion} with: isSensorWaiting {BooleanVar} with: isNotPartializable {BooleanVar} ^self create: permissions with: endorsements with: isSensorWaiting with: isNotPartializable! {BertProp} permissionsProp: iDs {XnRegion of: ID} ^BertProp make: iDs with: CurrentGrandMap fluidGet endorsementSpace emptyRegion with: false with: false! ! !BertProp class methodsFor: 'smalltalk: initialization'! linkTimeNonInherited TheIdentityBertProp _ NULL.! ! !BertProp class methodsFor: 'smalltalk: passe'! {BertProp} sensorWaitingProp self passe! !Prop subclass: #SensorProp instanceVariableNames: ' myRelevantPermissions {IDRegion} myRelevantEndorsements {CrossRegion of: IDRegion and: IDRegion} myPartialFlag {BooleanVar}' classVariableNames: ' TheIdentitySensorProp {SensorProp} ThePartialSensorProp {SensorProp} ' poolDictionaries: '' category: 'Xanadu-Be-Canopy-Prop'! SensorProp comment: 'The properties which are nevigable towards using the Sensor Canopy. The permissions and endorsements are those whose changes may affect the triggering of the recorders that decorate the canopy. myPartialFlag is a property of the o-leaf-stuff which are at the leaves of the Sensor Canopy.'! (SensorProp getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !SensorProp methodsFor: 'creation'! create: relevantPermissions {IDRegion} with: relevantEndorsements {CrossRegion of: IDRegion and: IDRegion} with: isPartial {BooleanVar} super create. myRelevantPermissions _ relevantPermissions. myRelevantEndorsements _ relevantEndorsements. myPartialFlag _ isPartial.! ! !SensorProp methodsFor: 'accessing'! {UInt32} flags ^SensorCrum flagsFor: myRelevantPermissions with: myRelevantEndorsements with: myPartialFlag! {BooleanVar} isPartial ^myPartialFlag! {CrossRegion} relevantEndorsements ^myRelevantEndorsements! {IDRegion} relevantPermissions ^myRelevantPermissions! {Prop} with: other {Prop} other cast: SensorProp into: [ :o | ^SensorProp make: ((myRelevantPermissions unionWith: o relevantPermissions) cast: IDRegion) with: ((myRelevantEndorsements unionWith: o relevantEndorsements) cast: CrossRegion) with: (myPartialFlag or: [o isPartial])]. ^ NULL "compiler fodder"! ! !SensorProp methodsFor: 'testing'! {UInt32} actualHashForEqual ^myRelevantPermissions hashForEqual bitXor: myRelevantEndorsements hashForEqual! {BooleanVar} isEqual: heaper {Heaper} heaper cast: SensorProp into: [ :prop | ^(myRelevantEndorsements isEqual: prop relevantEndorsements) and: [(myRelevantPermissions isEqual: prop relevantPermissions) and: [myPartialFlag == prop isPartial]]] others: [^false]. ^ false "compiler fodder"! ! !SensorProp methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << 'SensorProp(P: ' << myRelevantPermissions << '; E: ' << myRelevantEndorsements. myPartialFlag ifTrue: [oo << '; partial']. oo << ')'! ! !SensorProp methodsFor: 'smalltalk: passe'! {Filter of: (XuRegion of: ID)} endorsementsFilter self passe! {Filter of: (XuRegion of: ID)} permissionsFilter self passe! ! !SensorProp methodsFor: 'smalltalk: suspended'! {PropJoint} joint Ravi thingToDo. "implement proper simpleRegions so we can use simpleUnion" ^SensorPropJoint make: (myRelevantPermissions "asSimpleRegion" cast: IDRegion) with: (myRelevantEndorsements "asSimpleRegion" cast: CrossRegion) with: myPartialFlag! ! !SensorProp methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myRelevantPermissions _ receiver receiveHeaper. myRelevantEndorsements _ receiver receiveHeaper. myPartialFlag _ receiver receiveBooleanVar.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myRelevantPermissions. xmtr sendHeaper: myRelevantEndorsements. xmtr sendBooleanVar: myPartialFlag.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! SensorProp class instanceVariableNames: ''! (SensorProp getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !SensorProp class methodsFor: 'creation'! make "returns an empty SensorProp" TheIdentitySensorProp == NULL ifTrue: [TheIdentitySensorProp := self create: (CurrentGrandMap fluidGet globalIDSpace emptyRegion cast: IDRegion) with: (CurrentGrandMap fluidGet endorsementSpace emptyRegion cast: CrossRegion) with: false]. ^TheIdentitySensorProp! make: relevantPermissions {IDRegion} with: relevantEndorsements {CrossRegion} with: isPartial {BooleanVar} ^self create: relevantPermissions with: relevantEndorsements with: isPartial! {SensorProp} partial "returns an empty SensorProp with the partial flag on" ThePartialSensorProp == NULL ifTrue: [ThePartialSensorProp := self create: (CurrentGrandMap fluidGet globalIDSpace emptyRegion cast: IDRegion) with: (CurrentGrandMap fluidGet endorsementSpace emptyRegion cast: CrossRegion) with: true]. ^ThePartialSensorProp! ! !SensorProp class methodsFor: 'smalltalk: initialization'! linkTimeNonInherited TheIdentitySensorProp _ NULL. ThePartialSensorProp _ NULL.! !Heaper subclass: #PropChange instanceVariableNames: '' classVariableNames: ' TheBertPropChange {PropChange} TheCannotPartializeChange {PropChange} TheDetectorWaitingChange {PropChange} TheEndorsementsChange {PropChange} ThePermissionsChange {PropChange} TheSensorPropChange {PropChange} ' poolDictionaries: '' category: 'Xanadu-props'! PropChange comment: 'Each concrete class has just one canonical instance and no state. A PropChange is used to represent which property aspect changed (such as permission vs endorsement vs both).'! (PropChange getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !PropChange methodsFor: 'accessing'! {BooleanVar} areEqualProps: a {Prop} with: b {Prop} "compare the changed parts of two Props" self subclassResponsibility! {Prop} changed: old {Prop} with: a {Prop} "Return a Prop which is the same as 'old' for aspects which I don't represent as changing, and 'a' for aspects that I do represent as changing. This is used to replace Props with minimum effort, given that the 'a' parameter has only new props which are of the aspect this change replaces, while the 'old' parameter starts as the original set of Props, perhaps including other aspects. See also: with:with:, which unions rather than replacing." self subclassResponsibility! {PropFinder | NULL} fetchFinder: before {Prop} with: after {Prop} with: element {BeRangeElement} with: oldFinder {PropFinder | NULL} "return a finder looking for this change from before to after, in addition to whatever oldFinder is looking for (assumes this changes is a subset of oldFinder's change)" self subclassResponsibility! {BooleanVar} isFull "whether this is a complete change of props" self subclassResponsibility! {Prop} with: old {Prop} with: a {Prop} "Return a Prop which is the same as 'old' for aspects which I don't represent as changing, and the union of 'old' and 'a' for aspects that I do represent as changing. This is used to accumulate changes to Props with minimum effort, given that the 'a' parameter has only new props which are of the aspect this change changes, while the 'old' parameter starts as the original set of Props, perhaps including other aspects. See also changed:with:, which replaces rather than unioning." self subclassResponsibility! ! !PropChange methodsFor: 'testing'! {UInt32} actualHashForEqual ^self takeOop! {BooleanVar} isEqual: other {Heaper} ^self == other! ! !PropChange methodsFor: 'smalltalk: passe'! {PropFinder} fetchFinder: before {Prop} with: after {Prop} self passe "extra args"! {PropFinder} finderPartFrom: finder {PropFinder} self passe! ! !PropChange methodsFor: 'smalltalk: defaults'! {PropFinder | NULL} fetchFinder: before {Prop} with: after {Prop} with: element {BeRangeElement} ^self fetchFinder: before with: after with: element with: NULL! ! !PropChange methodsFor: 'smalltalk: suspended'! {BooleanVar} areEqualPropJoints: a {PropJoint} with: b {PropJoint} "compare the changed parts of two PropJoints" self subclassResponsibility! {PropJoint} changedJoint: old {PropJoint} with: a {PropJoint} "Return a PropJoint which is the same as 'old' for aspects which I don't represent as changing, and 'a' for aspects that I do represent as changing. This is used to replace PropJoints with minimum effort, given that the 'a' parameter has only new PropJoints which are of the aspect this change replaces, while the 'old' parameter starts as the original set of PropJoints, perhaps including other aspects. See also: change:with:, which does this for Props rather than PropJoints." self subclassResponsibility! {BooleanVar} isEqualToJointOf: a {PropJoint} with: b {Prop} "compare the changed parts of a PropJoint and a Prop" self subclassResponsibility! {PropJoint} join: old {PropJoint} with: a {PropJoint} with: b {PropJoint} "combine two PropJoints with minimum effort, given the previous result" self subclassResponsibility! {PropJoint} joinProp: old {PropJoint} with: a {PropJoint} with: b {PropJoint} with: prop {Prop} "combine two PropJoints and a prop with minimum effort, given the previous result" self subclassResponsibility! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PropChange class instanceVariableNames: ''! (PropChange getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !PropChange class methodsFor: 'pseudo constructors'! {PropChange} bertPropChange ^TheBertPropChange! {PropChange} cannotPartializeChange ^TheCannotPartializeChange! {PropChange} detectorWaitingChange ^TheDetectorWaitingChange! {PropChange} endorsementsChange ^TheEndorsementsChange! {PropChange} permissionsChange ^ThePermissionsChange! {PropChange} sensorPropChange "Returns the canonical PropChange object for propagating the properties that result from installing a recorder (permissions and endorsement filters). A better name would be recorderPropChange" ^TheSensorPropChange! ! !PropChange class methodsFor: 'smalltalk: initialization'! initTimeNonInherited TheCannotPartializeChange _ CannotPartializeChange create. TheDetectorWaitingChange _ DetectorWaitingChange create. TheEndorsementsChange _ EndorsementsChange create. TheBertPropChange _ BertPropChange create. TheSensorPropChange _ SensorPropChange create. ThePermissionsChange _ PermissionsChange create.! linkTimeNonInherited TheCannotPartializeChange _ NULL. TheDetectorWaitingChange _ NULL. TheEndorsementsChange _ NULL. TheBertPropChange _ NULL. TheSensorPropChange _ NULL. ThePermissionsChange _ NULL! !PropChange subclass: #CannotPartializeChange instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-props'! CannotPartializeChange comment: 'The "Cannot Partialize" property is a Bert Canopy property to remember that a Stamp is actively being viewed (by a session level Orgl) and therefore cannot be poured-out (made more partial). Should probably not be a Prop(erty), by rather a NOCOPY session level bit in the BertCrums.'! (CannotPartializeChange getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !CannotPartializeChange methodsFor: 'accessing'! {BooleanVar} areEqualProps: a {Prop} with: b {Prop} "compare the changed parts of two Props" ^(a cast: BertProp) isNotPartializable == (b cast: BertProp) isNotPartializable! {Prop} changed: old {Prop} with: a {Prop} | bp {BertProp wimpy} abp {BertProp wimpy} | bp _ old cast: BertProp. abp _ a cast: BertProp. bp isNotPartializable == abp isNotPartializable ifTrue: [^old]. ^BertProp make: bp permissions with: bp endorsements with: bp isSensorWaiting with: abp isNotPartializable! {PropFinder | NULL} fetchFinder: before {Prop unused} with: after {Prop unused} with: element {BeRangeElement unused} with: oldFinder {PropFinder unused | NULL} ^NULL! {BooleanVar} isFull "whether this is a complete change of props" ^false! {Prop} with: old {Prop} with: a {Prop} | bp {BertProp wimpy} abp {BertProp wimpy} | bp _ old cast: BertProp. abp _ a cast: BertProp. (bp isNotPartializable or: [abp isNotPartializable not]) ifTrue: [^old] ifFalse: [^BertProp make: bp permissions with: bp endorsements with: bp isSensorWaiting with: abp isNotPartializable]! ! !CannotPartializeChange methodsFor: 'smalltalk: suspended'! {BooleanVar} areEqualPropJoints: a {PropJoint} with: b {PropJoint} "compare the changed parts of two PropJoints" ^(a cast: BertPropJoint) isNotPartializable == (b cast: BertPropJoint) isNotPartializable! {PropJoint} changedJoint: old {PropJoint} with: a {PropJoint} | bpj {BertPropJoint wimpy} one {BertPropJoint wimpy} | bpj _ old cast: BertPropJoint. one _ a cast: BertPropJoint. bpj isNotPartializable == one isNotPartializable ifTrue: [^old] ifFalse: [^BertPropJoint make: bpj permissionsJoint with: bpj endorsementsJoint with: bpj isSensorWaiting with: bpj isNotPartializable not]! {BooleanVar} isEqualToJointOf: a {PropJoint} with: b {Prop} "compare the changed parts of a PropJoint and a Prop" ^(a cast: BertPropJoint) isNotPartializable == (b cast: BertProp) isNotPartializable! {PropJoint} join: old {PropJoint} with: a {PropJoint} with: b {PropJoint} "combine two PropJoints with minimum effort, given the previous result" | bpj {BertPropJoint wimpy} one {BertPropJoint wimpy} two {BertPropJoint wimpy} | bpj _ old cast: BertPropJoint. one _ a cast: BertPropJoint. two _ b cast: BertPropJoint. bpj isNotPartializable == (one isNotPartializable or: [two isNotPartializable]) ifTrue: [^old] ifFalse: [^BertPropJoint make: bpj permissionsJoint with: bpj endorsementsJoint with: bpj isSensorWaiting with: bpj isNotPartializable not]! {PropJoint} joinProp: old {PropJoint} with: a {PropJoint} with: b {PropJoint} with: prop {Prop} "combine two PropJoints and a prop with minimum effort, given the previous result" | bpj {BertPropJoint wimpy} one {BertPropJoint wimpy} two {BertPropJoint wimpy} p {BertProp wimpy} | bpj _ old cast: BertPropJoint. one _ a cast: BertPropJoint. two _ b cast: BertPropJoint. p _ prop cast: BertProp. bpj isNotPartializable == (one isNotPartializable or: [two isNotPartializable or: [p isNotPartializable]]) ifTrue: [^old] ifFalse: [^BertPropJoint make: bpj permissionsJoint with: bpj endorsementsJoint with: bpj isSensorWaiting with: bpj isNotPartializable not]! ! !CannotPartializeChange methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !PropChange subclass: #DetectorWaitingChange instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-props'! DetectorWaitingChange comment: 'The "Detector Waiting" property is a Bert Canopy property to remember that an Edition has a Detector waiting for PlaceHolders to be filled in.'! (DetectorWaitingChange getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !DetectorWaitingChange methodsFor: 'accessing'! {BooleanVar} areEqualProps: a {Prop} with: b {Prop} "compare the changed parts of two Props" ^(a cast: BertProp) isSensorWaiting == (b cast: BertProp) isSensorWaiting! {Prop} changed: old {Prop} with: a {Prop} | bp {BertProp wimpy} abp {BertProp wimpy} | bp _ old cast: BertProp. abp _ a cast: BertProp. bp isSensorWaiting == abp isSensorWaiting ifTrue: [^old]. ^BertProp make: bp permissions with: bp endorsements with: abp isSensorWaiting with: bp isNotPartializable! {PropFinder | NULL} fetchFinder: before {Prop unused} with: after {Prop unused} with: element {BeRangeElement unused} with: oldFinder {PropFinder unused | NULL} ^NULL! {BooleanVar} isFull ^false! {Prop} with: old {Prop} with: a {Prop} | bp {BertProp wimpy} abp {BertProp wimpy} | bp _ old cast: BertProp. abp _ a cast: BertProp. (bp isSensorWaiting or: [abp isSensorWaiting not]) ifTrue: [^old] ifFalse: [^BertProp make: bp permissions with: bp endorsements with: abp isSensorWaiting with: bp isNotPartializable]! ! !DetectorWaitingChange methodsFor: 'smalltalk: suspended'! {BooleanVar} areEqualPropJoints: a {PropJoint} with: b {PropJoint} "compare the changed parts of two PropJoints" ^(a cast: BertPropJoint) isSensorWaiting == (b cast: BertPropJoint) isSensorWaiting! {PropJoint} changedJoint: old {PropJoint} with: a {PropJoint} | bpj {BertPropJoint wimpy} one {BertPropJoint wimpy} | bpj _ old cast: BertPropJoint. one _ a cast: BertPropJoint. bpj isSensorWaiting == one isSensorWaiting ifTrue: [^old] ifFalse: [^BertPropJoint make: bpj permissionsJoint with: bpj endorsementsJoint with: one isSensorWaiting with: bpj isNotPartializable]! {BooleanVar} isEqualToJointOf: a {PropJoint} with: b {Prop} ^(a cast: BertPropJoint) isSensorWaiting == (b cast: BertProp) isSensorWaiting! {PropJoint} join: old {PropJoint} with: a {PropJoint} with: b {PropJoint} | bpj {BertPropJoint wimpy} one {BertPropJoint wimpy} two {BertPropJoint wimpy} | bpj _ old cast: BertPropJoint. one _ a cast: BertPropJoint. two _ b cast: BertPropJoint. bpj isSensorWaiting == (one isSensorWaiting or: [two isSensorWaiting]) ifTrue: [^old] ifFalse: [^BertPropJoint make: bpj permissionsJoint with: bpj endorsementsJoint with: bpj isSensorWaiting not with: bpj isNotPartializable]! {PropJoint} joinProp: old {PropJoint} with: a {PropJoint} with: b {PropJoint} with: prop {Prop} | bpj {BertPropJoint wimpy} one {BertPropJoint wimpy} two {BertPropJoint wimpy} p {BertProp wimpy} | bpj _ old cast: BertPropJoint. one _ a cast: BertPropJoint. two _ b cast: BertPropJoint. p _ prop cast: BertProp. bpj isSensorWaiting == (one isSensorWaiting or: [two isSensorWaiting or: [p isSensorWaiting]]) ifTrue: [^old] ifFalse: [^BertPropJoint make: bpj permissionsJoint with: bpj endorsementsJoint with: bpj isSensorWaiting not with: bpj isNotPartializable]! ! !DetectorWaitingChange methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !PropChange subclass: #EndorsementsChange instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-props'! EndorsementsChange comment: 'Used when the Endorsement part of a BertProp changed'! (EndorsementsChange getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !EndorsementsChange methodsFor: 'accessing'! {BooleanVar} areEqualProps: a {Prop} with: b {Prop} "compare the changed parts of two Props" ^(a cast: BertProp) endorsements isEqual: (b cast: BertProp) endorsements! {Prop} changed: old {Prop} with: a {Prop} | bp {BertProp wimpy} | bp _ old cast: BertProp. ^BertProp make: bp permissions with: (a cast: BertProp) endorsements with: bp isSensorWaiting with: bp isNotPartializable! {PropFinder | NULL} fetchFinder: before {Prop} with: after {Prop} with: element {BeRangeElement} with: oldFinder {PropFinder | NULL} before cast: BertProp into: [ :b | after cast: BertProp into: [ :a | | result {PropFinder} delta {RegionDelta} any {PropFinder} anys {ImmuSet} simple {PropFinder} simples {ImmuSet} | delta := RegionDelta make: b endorsements with: a endorsements. delta isSame ifTrue: [^NULL]. any := AnyRecorderEFinder make: (a permissions cast: IDRegion) with: delta. any isEmpty ifTrue: [anys := ImmuSet make] ifFalse: [anys := ImmuSet newWith: any]. simple := OriginalResultRecorderEFinder make: element with: (a permissions cast: IDRegion) with: delta. simple isEmpty ifTrue: [simples := ImmuSet make] ifFalse: [simples := ImmuSet newWith: simple]. oldFinder == NULL ifTrue: [result := CumulativeRecorderFinder make: anys with: simples with: ImmuSet make] ifFalse: [oldFinder cast: CumulativeRecorderFinder into: [ :crf | result := CumulativeRecorderFinder make: anys with: simples with: (crf current unionWith: crf others)]]. result isEmpty ifTrue: [^NULL] ifFalse: [^result]]]. ^NULL "fodder"! {BooleanVar} isFull "whether this is a complete change of props" ^false! {Prop} with: old {Prop} with: a {Prop} | bp {BertProp wimpy} | bp _ old cast: BertProp. ^BertProp make: bp permissions with: ((a cast: BertProp) endorsements unionWith: bp endorsements) with: bp isSensorWaiting with: bp isNotPartializable! ! !EndorsementsChange methodsFor: 'smalltalk: suspended'! {BooleanVar} areEqualPropJoints: a {PropJoint} with: b {PropJoint} "compare the changed parts of two PropJoints" ^(a cast: BertPropJoint) endorsementsJoint isEqual: (b cast: BertPropJoint) endorsementsJoint! {PropJoint} changedJoint: old {PropJoint} with: a {PropJoint} | bertprop {BertPropJoint wimpy} | bertprop _ old cast: BertPropJoint. ^BertPropJoint make: bertprop permissionsJoint with: (a cast: BertPropJoint) endorsementsJoint with: bertprop isSensorWaiting with: bertprop isNotPartializable! {BooleanVar} isEqualToJointOf: a {PropJoint} with: b {Prop} "compare the changed parts of a PropJoint and a Prop" ^(a cast: BertPropJoint) endorsementsJoint unioned isEqual: (b cast: BertProp) endorsements! {PropJoint} join: old {PropJoint} with: a {PropJoint} with: b {PropJoint} "combine two PropJoints with minimum effort, given the previous result" | bertprop {BertPropJoint wimpy} | bertprop _ old cast: BertPropJoint. ^BertPropJoint make: bertprop permissionsJoint with: ((a cast: BertPropJoint) endorsementsJoint join: (b cast: BertPropJoint) endorsementsJoint) with: bertprop isSensorWaiting with: bertprop isNotPartializable! {PropJoint} joinProp: old {PropJoint} with: a {PropJoint} with: b {PropJoint} with: prop {Prop} "combine two PropJoints and a prop with minimum effort, given the previous result" | bpj {BertPropJoint wimpy} | bpj _ old cast: BertPropJoint. ^BertPropJoint make: bpj permissionsJoint with: (((a cast: BertPropJoint) endorsementsJoint join: (b cast: BertPropJoint) endorsementsJoint) with: (prop cast: BertProp) endorsements) with: bpj isSensorWaiting with: bpj isNotPartializable! ! !EndorsementsChange methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !PropChange subclass: #FullPropChange instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-props'! FullPropChange comment: 'Use this to indicate that all aspects of the Prop may have changed.'! (FullPropChange getOrMakeCxxClassDescription) attributes: ((Set new) add: #NOT.A.TYPE; add: #DEFERRED; yourself)! !FullPropChange methodsFor: 'accessing'! {BooleanVar} areEqualProps: a {Prop} with: b {Prop} "compare the changed parts of two Props" ^a isEqual: b! {Prop} changed: old {Prop unused} with: a {Prop} ^a! {PropFinder | NULL} fetchFinder: before {Prop} with: after {Prop} with: element {BeRangeElement} with: oldFinder {PropFinder | NULL} self subclassResponsibility! {BooleanVar} isFull "whether this is a complete change of props" ^true! {Prop} with: old {Prop} with: a {Prop} ^old with: a! ! !FullPropChange methodsFor: 'smalltalk: suspended'! {BooleanVar} areEqualPropJoints: a {PropJoint} with: b {PropJoint} "compare the changed parts of two PropJoints" ^a isEqual: b! {PropJoint} changedJoint: old {PropJoint unused} with: a {PropJoint} ^a! {BooleanVar} isEqualToJointOf: a {PropJoint} with: b {Prop} "compare the changed parts of a PropJoint and a Prop" self subclassResponsibility! {PropJoint} join: old {PropJoint unused} with: a {PropJoint} with: b {PropJoint} "combine two PropJoints with minimum effort, given the previous result" ^a join: b! {PropJoint} joinProp: old {PropJoint unused} with: a {PropJoint} with: b {PropJoint} with: prop {Prop} "combine two PropJoints and a prop with minimum effort, given the previous result" ^(a join: b) with: prop! !FullPropChange subclass: #BertPropChange instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-props'! BertPropChange comment: 'Use when it is fine to consider that all aspects of the BertProp may have changed'! (BertPropChange getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !BertPropChange methodsFor: 'accessing'! {PropFinder | NULL} fetchFinder: before {Prop} with: after {Prop} with: element {BeRangeElement} with: oldFinder {PropFinder | NULL} | p {PropFinder} e {PropFinder} | p := PropChange permissionsChange fetchFinder: before with: after with: element with: oldFinder. e := PropChange endorsementsChange fetchFinder: before with: after with: element with: oldFinder. p == NULL ifTrue: [^e]. e == NULL ifTrue: [^p]. p cast: CumulativeRecorderFinder into: [ :pcrf | e cast: CumulativeRecorderFinder into: [ :ecrf | ^CumulativeRecorderFinder make: (pcrf generators unionWith: ecrf generators) with: (pcrf current unionWith: ecrf current) with: (pcrf others unionWith: ecrf others)]]. ^NULL "fodder"! ! !BertPropChange methodsFor: 'smalltalk: suspended'! {BooleanVar} isEqualToJointOf: a {PropJoint} with: b {Prop} "compare the changed parts of a PropJoint and a Prop" | bpj {BertPropJoint wimpy} bp {BertProp wimpy} | bpj _ a cast: BertPropJoint. bp _ b cast: BertProp. ^(bpj endorsementsJoint unioned isEqual: bp endorsements) and: [(bpj permissionsJoint unioned isEqual: bp permissions) and: [bpj isSensorWaiting == bp isSensorWaiting and: [bpj isNotPartializable == bp isNotPartializable]]]! ! !BertPropChange methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !FullPropChange subclass: #SensorPropChange instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-props'! SensorPropChange comment: 'Use when it is fine to consider that all aspects of the SensorProp may have changed'! (SensorPropChange getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !SensorPropChange methodsFor: 'accessing'! {PropFinder | NULL} fetchFinder: before {Prop unused} with: after {Prop unused} with: element {BeRangeElement unused} with: oldFinder {PropFinder unused | NULL} ^NULL! ! !SensorPropChange methodsFor: 'smalltalk: suspended'! {BooleanVar} isEqualToJointOf: a {PropJoint} with: b {Prop} a cast: SensorPropJoint into: [ :spj | b cast: SensorProp into: [ :sp | ^(spj relevantEndorsements isEqual: sp relevantEndorsements) and: [(spj relevantPermissions isEqual: sp relevantPermissions) and: [spj isPartial == sp isPartial]]]]. ^false "fodder"! ! !SensorPropChange methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !PropChange subclass: #PermissionsChange instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-props'! PermissionsChange comment: 'Used when the Permissions part of a BertProp changed'! (PermissionsChange getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !PermissionsChange methodsFor: 'accessing'! {BooleanVar} areEqualProps: a {Prop} with: b {Prop} "compare the changed parts of two Props" ^(a cast: BertProp) permissions isEqual: (b cast: BertProp) permissions! {Prop} changed: old {Prop} with: a {Prop} | bp {BertProp wimpy} | bp _ old cast: BertProp. ^BertProp make: (a cast: BertProp) permissions with: bp endorsements with: bp isSensorWaiting with: bp isNotPartializable! {PropFinder | NULL} fetchFinder: before {Prop} with: after {Prop} with: element {BeRangeElement} with: oldFinder {PropFinder | NULL} before cast: BertProp into: [ :b | after cast: BertProp into: [ :a | | result {PropFinder} delta {RegionDelta} any {PropFinder} anys {ImmuSet} simple {PropFinder} simples {ImmuSet} | delta := RegionDelta make: b permissions with: a permissions. delta isSame ifTrue: [^NULL]. any := AnyRecorderPFinder make: delta. any isEmpty ifTrue: [anys := ImmuSet make] ifFalse: [anys := ImmuSet newWith: any]. simple :=ResultRecorderPFinder make: element with: delta with: a endorsements. simple isEmpty ifTrue: [simples := ImmuSet make] ifFalse: [simples := ImmuSet newWith: simple]. oldFinder == NULL ifTrue: [result := CumulativeRecorderFinder make: anys with: simples with: ImmuSet make] ifFalse: [oldFinder cast: CumulativeRecorderFinder into: [ :crf | result := CumulativeRecorderFinder make: anys with: simples with: (crf current unionWith: crf others)]]. result isEmpty ifTrue: [^NULL] ifFalse: [^result]]]. ^NULL "fodder"! {BooleanVar} isFull "whether this is a complete change of props" ^false! {Prop} with: old {Prop} with: a {Prop} | bp {BertProp wimpy} | bp _ old cast: BertProp. ^BertProp make: ((a cast: BertProp) permissions unionWith: bp permissions) with: bp endorsements with: bp isSensorWaiting with: bp isNotPartializable! ! !PermissionsChange methodsFor: 'smalltalk: suspended'! {BooleanVar} areEqualPropJoints: a {PropJoint} with: b {PropJoint} "compare the changed parts of two PropJoints" ^(a cast: BertPropJoint) permissionsJoint isEqual: (b cast: BertPropJoint) permissionsJoint! {PropJoint} changedJoint: old {PropJoint} with: a {PropJoint} | bp {BertPropJoint wimpy} | bp _ old cast: BertPropJoint. ^BertPropJoint make: (a cast: BertPropJoint) permissionsJoint with: bp endorsementsJoint with: bp isSensorWaiting with: bp isNotPartializable! {BooleanVar} isEqualToJointOf: a {PropJoint} with: b {Prop} "compare the changed parts of a PropJoint and a Prop" ^(a cast: BertPropJoint) permissionsJoint unioned isEqual: (b cast: BertProp) permissions! {PropJoint} join: old {PropJoint} with: a {PropJoint} with: b {PropJoint} "combine two PropJoints with minimum effort, given the previous result" | bp {BertPropJoint wimpy} | bp _ old cast: BertPropJoint. ^BertPropJoint make: ((a cast: BertPropJoint) permissionsJoint join: (b cast: BertPropJoint) permissionsJoint) with: bp endorsementsJoint with: bp isSensorWaiting with: bp isNotPartializable! {PropJoint} joinProp: old {PropJoint} with: a {PropJoint} with: b {PropJoint} with: prop {Prop} "combine two PropJoints and a prop with minimum effort, given the previous result" | bpj {BertPropJoint wimpy} | bpj _ old cast: BertPropJoint. ^BertPropJoint make: (((a cast: BertPropJoint) permissionsJoint join: (b cast: BertPropJoint) permissionsJoint) with: (prop cast: BertProp) permissions) with: bpj endorsementsJoint with: bpj isSensorWaiting with: bpj isNotPartializable! ! !PermissionsChange methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !Heaper subclass: #PropFinder instanceVariableNames: 'myFlags {UInt32}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Canopy'! PropFinder comment: 'For filtering by canopies. Matches against Props and CanopyCrum flags'! (PropFinder getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !PropFinder methodsFor: 'create'! create super create "for generated code"! create: flags {UInt32} super create. myFlags := flags.! ! !PropFinder methodsFor: 'accessing'! {BooleanVar} doesPass: parent {CanopyCrum} "return whether the propJoint passes the finder" ^(myFlags bitOr: parent flags) ~= UInt32Zero! {PropFinder} findPast: stamp {BeEdition} "During a southwards walk of a multi-Edition (aka multi-Stamp), normally we simplify the finder by using PropFinder>>pass:. However, when we cross an internal Edition boundary and are about to walk into the O-plane of that contained edition we call this method (findPast:) to get the new PropFinder." self subclassResponsibility! {UInt32} flags ^myFlags! {BooleanVar} isEmpty "Overridden only in ClosedPropFinder" ^false! {BooleanVar} isFull "Overridden only in OpenPropFinder" ^false! {BooleanVar} match: prop {Prop} "tell whether a prop matches this filter" self subclassResponsibility! {PropFinder} pass: parent {CanopyCrum} "return a simple enough finder for looking at the children" (self doesPass: parent) ifTrue: [^self] ifFalse: [^PropFinder closedPropFinder]! ! !PropFinder methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PropFinder class instanceVariableNames: ''! (PropFinder getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !PropFinder class methodsFor: 'creation'! {PropFinder} backfollowFinder: permissionsFilter {Filter of: (XnRegion of: ID)} permissionsFilter isEmpty ifTrue: [^PropFinder closedPropFinder] ifFalse: [^BackfollowPFinder create: (BertCrum flagsFor: (permissionsFilter relevantRegion cast: IDRegion) with: NULL with: false with: false) with: permissionsFilter]! {PropFinder} backfollowFinder: permissionsFilter {Filter of: (XnRegion of: ID)} with: endorsementsFilter {Filter of: (XnRegion of: ID)} (permissionsFilter isEmpty or: [endorsementsFilter isEmpty]) ifTrue: [^PropFinder closedPropFinder]. endorsementsFilter isFull ifTrue: [^BackfollowPFinder create: (BertCrum flagsFor: (permissionsFilter relevantRegion cast: IDRegion) with: NULL with: false with: false) with: permissionsFilter]. ^BackfollowFinder create: (BertCrum flagsFor: (permissionsFilter relevantRegion cast: IDRegion) with: (endorsementsFilter relevantRegion cast: CrossRegion) with: false with: false) with: permissionsFilter with: endorsementsFilter! {PropFinder} cannotPartializeFinder ^CannotPartializeFinder create! {PropFinder} closedPropFinder ^ClosedPropFinder create! {PropFinder} openPropFinder ^OpenPropFinder create! {PropFinder} sensorFinder ^SensorFinder create! ! !PropFinder class methodsFor: 'smalltalk: passe'! {PropFinder} partialityFinder self passe! {PropFinder} recorderFinder.RegionDelta: permissionsDelta {RegionDelta of: (XuRegion of: ID)} with.RegionDelta: endorsementsDelta {RegionDelta of: (XuRegion of: ID)} self passe.! {PropFinder} recorderFinder.RegionDelta: permissionsDelta {RegionDelta of: (XuRegion of: ID)} with.XuRegion: endorsements {XuRegion of: ID} self passe.! {PropFinder} recorderFinder.XuRegion: permissions {XuRegion of: ID} with.RegionDelta: endorsementsDelta {RegionDelta of: (XuRegion of: ID)} self passe.! {PropFinder} recorderPFinder: element {BeRangeElement} with: permissionsDelta {RegionDelta of: IDRegion} with: endorsements {CrossRegion of: IDRegion and: IDRegion} self passe! !PropFinder subclass: #BertPropFinder instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Canopy'! BertPropFinder comment: 'Used to filter by the bert canopy'! (BertPropFinder getOrMakeCxxClassDescription) attributes: ((Set new) add: #NOT.A.TYPE; add: #DEFERRED; yourself)! !BertPropFinder methodsFor: 'create'! create super create "for comm"! create: flags {UInt32} super create: flags! ! !BertPropFinder methodsFor: 'accessing'! {PropFinder} findPast: edition {BeEdition} self subclassResponsibility! {BooleanVar} match: prop {Prop} "tell whether a prop matches this filter" self subclassResponsibility! ! !BertPropFinder methodsFor: 'smalltalk: suspended'! {PropFinder} oldPass: parent {PropJoint} "return a simple enough finder for looking at the children" self subclassResponsibility! !BertPropFinder subclass: #BackfollowFinder instanceVariableNames: ' myPermissionsFilter {Filter of: (XnRegion of: ID)} myEndorsementsFilter {Filter of: (XnRegion of: ID)}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Canopy'! BackfollowFinder comment: 'Finder used to filter the htree walk by the bert canopy when doing a backFollow which uses both permissions and endorsement filters'! (BackfollowFinder getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !BackfollowFinder methodsFor: 'creation'! create: flags {UInt32} with: permissionsFilter {Filter of: (XnRegion of: ID)} with: endorsementsFilter {Filter of: (CrossRegion of: ID)} super create: flags. myPermissionsFilter _ permissionsFilter. myEndorsementsFilter _ endorsementsFilter! ! !BackfollowFinder methodsFor: 'accessing'! {Filter of: (XnRegion of: ID)} endorsementsFilter ^myEndorsementsFilter! {PropFinder} findPast: edition {BeEdition} | canSee {BooleanVar} endorsements {XnRegion} | Ravi thingToDo. "use regions in finder so that we don't need to create intermediate objects" canSee := false. endorsements := edition endorsements. edition currentWorks stepper forEach: [ :work {BeWork} | ((work fetchReadClub ~~ NULL and: [myPermissionsFilter match: work fetchReadClub asRegion]) or: [work fetchEditClub ~~ NULL and: [myPermissionsFilter match: work fetchEditClub asRegion]]) ifTrue: [canSee := true. endorsements := endorsements unionWith: work endorsements]]. (myEndorsementsFilter match: endorsements) ifTrue: [canSee ifTrue: [^PropFinder openPropFinder] ifFalse: [^PropFinder backfollowFinder: myPermissionsFilter]]. ^self! {BooleanVar} match: prop {Prop} "tell whether a prop matches this filter" | p {BertProp wimpy} | p _ prop cast: BertProp. ^(myPermissionsFilter match: p permissions) and: [myEndorsementsFilter match: p endorsements]! {Filter of: (XnRegion of: ID)} permissionsFilter ^myPermissionsFilter! ! !BackfollowFinder methodsFor: 'testing'! {UInt32} actualHashForEqual ^(self getCategory hashForEqual bitXor: myPermissionsFilter hashForEqual) bitXor: myEndorsementsFilter hashForEqual! {BooleanVar} isEqual: other {Heaper} other cast: BackfollowFinder into: [:o | ^(myPermissionsFilter isEqual: o permissionsFilter) and: [myEndorsementsFilter isEqual: o endorsementsFilter]] others: [^false]. ^false "fodder"! ! !BackfollowFinder methodsFor: 'smalltalk: suspended'! {PropFinder} oldPass: parent {PropJoint} "return a simple enough finder for looking at the children" | p {BertPropJoint wimpy} | p _ parent cast: BertPropJoint. ^PropFinder backfollowFinder: (myPermissionsFilter pass: p permissionsJoint) with: (myEndorsementsFilter pass: p endorsementsJoint)! ! !BackfollowFinder methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myPermissionsFilter _ receiver receiveHeaper. myEndorsementsFilter _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myPermissionsFilter. xmtr sendHeaper: myEndorsementsFilter.! !BertPropFinder subclass: #BackfollowPFinder instanceVariableNames: 'myPermissionsFilter {Filter of: (XnRegion of: ID)}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Canopy'! BackfollowPFinder comment: 'Finder used to filter the htree walk by the bert canopy when doing a backFollow which uses just permissions filters'! (BackfollowPFinder getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !BackfollowPFinder methodsFor: 'creation'! create: flags {UInt32} with: permissionsFilter {Filter of: (XnRegion of: ID)} super create: flags. myPermissionsFilter _ permissionsFilter! ! !BackfollowPFinder methodsFor: 'accessing'! {PropFinder} findPast: edition {BeEdition} Ravi thingToDo. "use regions in finder so that we don't need to create intermediate objects" edition currentWorks stepper forEach: [ :work {BeWork} | ((work fetchReadClub ~~ NULL and: [myPermissionsFilter match: work fetchReadClub asRegion]) or: [work fetchEditClub ~~ NULL and: [myPermissionsFilter match: work fetchEditClub asRegion]]) ifTrue: [^PropFinder openPropFinder]]. ^self! {BooleanVar} match: prop {Prop} "tell whether a prop matches this filter" ^myPermissionsFilter match: (prop cast: BertProp) permissions! {Filter of: (XnRegion of: ID)} permissionsFilter ^myPermissionsFilter! ! !BackfollowPFinder methodsFor: 'testing'! {UInt32} actualHashForEqual ^self getCategory hashForEqual bitXor: myPermissionsFilter hashForEqual! {BooleanVar} isEqual: other {Heaper} other cast: BackfollowPFinder into: [:o | ^myPermissionsFilter isEqual: o permissionsFilter] others: [^false]. ^false "fodder"! ! !BackfollowPFinder methodsFor: 'smalltalk: suspended'! {PropFinder} oldPass: parent {PropJoint} "return a simple enough finder for looking at the children" ^PropFinder backfollowFinder: (myPermissionsFilter pass: (parent cast: BertPropJoint) permissionsJoint)! ! !BackfollowPFinder methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myPermissionsFilter _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myPermissionsFilter.! !BertPropFinder subclass: #CannotPartializeFinder instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Canopy'! CannotPartializeFinder comment: 'Used to figure out which Stamps have Orgls on them so that the archiver can knw that they cannot be partialized. Will go away because the state described is session level state and therefore should be store in NOCOPY variables instead of in the Canopy''s Props.'! (CannotPartializeFinder getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !CannotPartializeFinder methodsFor: 'create'! create super create: BertCrum isNotPartializableFlag! ! !CannotPartializeFinder methodsFor: 'accessing'! {PropFinder} findPast: edition {BeEdition unused} ^self "inability to partialize is transitive"! {BooleanVar} match: prop {Prop} "tell whether a prop matches this filter" ^(prop cast: BertProp) isNotPartializable! ! !CannotPartializeFinder methodsFor: 'testing'! {UInt32} actualHashForEqual ^self getCategory hashForEqual! {BooleanVar} isEqual: other {Heaper} ^other isKindOf: CannotPartializeFinder! ! !CannotPartializeFinder methodsFor: 'smalltalk: suspended'! {PropFinder} oldPass: parent {PropJoint} "return a simple enough finder for looking at the children" (parent cast: BertPropJoint) isNotPartializable ifTrue: [^self] ifFalse: [^PropFinder closedPropFinder]! ! !CannotPartializeFinder methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !BertPropFinder subclass: #SensorFinder instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Canopy'! SensorFinder comment: 'Currently unused but will be re-instated. Used to find which containing Editions have WaitForCompletionDetectors installed on them so that they can be rung when placegholders get filled in.'! (SensorFinder getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !SensorFinder methodsFor: 'create'! create super create: BertCrum isSensorWaitingFlag! ! !SensorFinder methodsFor: 'accessing'! {PropFinder} findPast: edition {BeEdition unused} ^PropFinder closedPropFinder "Dont look for Detectors past an Edition boundary"! {BooleanVar} match: prop {Prop} "tell whether a prop matches this filter" ^(prop cast: BertProp) isSensorWaiting! ! !SensorFinder methodsFor: 'testing'! {UInt32} actualHashForEqual ^self getCategory hashForEqual! {BooleanVar} isEqual: other {Heaper} ^other isKindOf: SensorFinder! ! !SensorFinder methodsFor: 'smalltalk: suspended'! {PropFinder} oldPass: parent {PropJoint} "return a simple enough finder for looking at the children" (parent cast: BertPropJoint) isSensorWaiting ifTrue: [^self] ifFalse: [^PropFinder closedPropFinder]! ! !SensorFinder methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !PropFinder subclass: #ClosedPropFinder instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Canopy'! ClosedPropFinder comment: 'The finder which matches nothing. Used to indicate that this subtree is known to be useless (no matches possible below here).'! (ClosedPropFinder getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !ClosedPropFinder methodsFor: 'accessing'! {PropFinder} findPast: stamp {BeEdition unused} ^self! {BooleanVar} isEmpty "Overridden only here" ^true! {BooleanVar} match: prop {Prop unused} "tell whether a prop matches this filter" ^false! {PropFinder} pass: crum {CanopyCrum unused} ^self! ! !ClosedPropFinder methodsFor: 'testing'! {UInt32} actualHashForEqual ^self getCategory hashForEqual! {BooleanVar} isEqual: other {Heaper} ^other isKindOf: ClosedPropFinder! ! !ClosedPropFinder methodsFor: 'create'! create super create: UInt32Zero! ! !ClosedPropFinder methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !PropFinder subclass: #OpenPropFinder instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Canopy'! OpenPropFinder comment: 'The finder which matches everything. Used to indicate that everything below here necessarily matches.'! (OpenPropFinder getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !OpenPropFinder methodsFor: 'accessing'! {PropFinder} findPast: stamp {BeEdition unused} ^self! {BooleanVar} isFull ^true! {BooleanVar} match: prop {Prop unused} "tell whether a prop matches this filter" ^true! {PropFinder} pass: crum {CanopyCrum unused} ^self! ! !OpenPropFinder methodsFor: 'testing'! {UInt32} actualHashForEqual ^self getCategory hashForEqual! {BooleanVar} isEqual: other {Heaper} ^other isKindOf: OpenPropFinder! ! !OpenPropFinder methodsFor: 'create'! create super create: UInt32Zero bitInvert! ! !OpenPropFinder methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !PropFinder subclass: #SensorPropFinder instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Canopy'! SensorPropFinder comment: 'Used to filter by the sensor canopy'! (SensorPropFinder getOrMakeCxxClassDescription) attributes: ((Set new) add: #NOT.A.TYPE; add: #DEFERRED; yourself)! !SensorPropFinder methodsFor: 'create'! create super create "for generated code"! create: flags {UInt32} super create: flags! ! !SensorPropFinder methodsFor: 'accessing'! {PropFinder} findPast: stamp {BeEdition} self subclassResponsibility! {BooleanVar} match: prop {Prop} "tell whether a prop matches this filter" self subclassResponsibility! ! !SensorPropFinder methodsFor: 'smalltalk: suspended'! {PropFinder} oldPass: crum {CanopyCrum} self subclassResponsibility! !SensorPropFinder subclass: #AbstractRecorderFinder instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Canopy'! AbstractRecorderFinder comment: 'The finders used to find recorders in the sensor canopy in response to some change in props of a Stamp.'! (AbstractRecorderFinder getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !AbstractRecorderFinder methodsFor: 'create'! create super create "for generated code"! create: flags {UInt32} super create: flags! ! !AbstractRecorderFinder methodsFor: 'accessing'! {PropFinder} findPast: stamp {BeEdition} self subclassResponsibility! {BooleanVar} match: prop {Prop} "tell whether a prop matches this filter" self subclassResponsibility! ! !AbstractRecorderFinder methodsFor: 'recording'! {void} checkRecorder: recorder {ResultRecorder} with: fossil {RecorderFossil} "While doing one step of a southward walk in the O-tree, filtered by the sensor canopy, looking for recorders that represent queries that are newly passed by the change of properties, where the object that changed properties and the change itself are represented by my state, record my object into the recorder if it newly passes the recorder's filtering criteria. See class comments of the various subclasses for details on the purpose of each kindOf AbstractRecorderFinder." self subclassResponsibility! ! !AbstractRecorderFinder methodsFor: 'smalltalk: passe'! {void} checkStamp: stamp {BeEdition} with: recorder {TransclusionRecorder} "record the stamp into the recorder if I pass this recorder's filters" self passe! {void} checkStamp: stamp {BeEdition} with: recorder {TransclusionRecorder} with: fossil {RecorderFossil} "While doing one step of a southward walk in the O-tree, filtered by the sensor canopy, looking for recorders that represent queries that are newly passed by the change of properties in the Stamp (said change in properties being represented by my state), record the stamp into the recorder if the stamp newly passes the fossil's filtering criteria. See class comments of the various subclasses for details on the purpose of each kindOf AbstractRecorderFinder." self passe! ! !AbstractRecorderFinder methodsFor: 'smalltalk: suspended'! {PropFinder} oldPass: crum {CanopyCrum} self subclassResponsibility! !AbstractRecorderFinder subclass: #AnyRecorderFinder instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Canopy'! AnyRecorderFinder comment: 'NOT.A.TYPE A general superclass for finders that looks for all recorders, and all elements they might find, resulting from a given change.'! (AnyRecorderFinder getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !AnyRecorderFinder methodsFor: 'create'! create super create "for generated code"! create: flags {UInt32} super create: flags! ! !AnyRecorderFinder methodsFor: 'recording'! {void} checkRecorder: recorder {ResultRecorder} with: fossil {RecorderFossil} "do nothing"! ! !AnyRecorderFinder methodsFor: 'accessing'! {PropFinder} findPast: stamp {BeEdition unused} ^self! {BooleanVar} match: prop {Prop} self subclassResponsibility! {PropFinder} nextFinder: edition {BeEdition} "An additional finder to use below the given Edition" self subclassResponsibility! ! !AnyRecorderFinder methodsFor: 'smalltalk: suspended'! {PropFinder} oldPass: parent {PropJoint} self subclassResponsibility! !AnyRecorderFinder subclass: #AnyRecorderEFinder instanceVariableNames: ' myPermissions {IDRegion} myEndorsementsDelta {RegionDelta of: CrossRegion} myNewEndorsements {CrossRegion}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Canopy'! AnyRecorderEFinder comment: 'Generates finders for recorders triggered by an increase in endorsements. Also remembers the (approximate) permissions on the object whose endorsements changed'! (AnyRecorderEFinder getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !AnyRecorderEFinder methodsFor: 'accessing'! {RegionDelta of: CrossRegion} endorsementsDelta ^myEndorsementsDelta! {BooleanVar} match: prop {Prop} prop cast: SensorProp into: [ :p | ^(p relevantPermissions intersects: myPermissions) and: [p relevantEndorsements intersects: myNewEndorsements]]. ^false "fodder"! {CrossRegion} newEndorsements ^myNewEndorsements! {PropFinder} nextFinder: edition {BeEdition} ^ContainedEditionRecorderEFinder make: edition with: myPermissions with: myEndorsementsDelta with: myNewEndorsements! {IDRegion} permissions ^myPermissions! ! !AnyRecorderEFinder methodsFor: 'create'! create: flags {UInt32} with: permissions {IDRegion} with: endorsementsDelta {RegionDelta of: CrossRegion} with: newEndorsements {CrossRegion} super create: flags. myPermissions := permissions. myEndorsementsDelta := endorsementsDelta. myNewEndorsements := newEndorsements.! ! !AnyRecorderEFinder methodsFor: 'testing'! {UInt32} actualHashForEqual ^(myPermissions hashForEqual bitXor: myEndorsementsDelta hashForEqual) bitXor: myNewEndorsements hashForEqual! {BooleanVar} isEqual: heaper {Heaper} heaper cast: AnyRecorderEFinder into: [ :other | ^(myPermissions isEqual: other permissions) and: [(myEndorsementsDelta isEqual: other endorsementsDelta) and: [myNewEndorsements isEqual: other newEndorsements]]] others: [^false]. ^false "fodder"! ! !AnyRecorderEFinder methodsFor: 'smalltalk: suspended'! {PropFinder} oldPass: parent {PropJoint} parent cast: SensorPropJoint into: [ :p | ^AnyRecorderEFinder make: ((p relevantPermissions intersect: myPermissions) cast: IDRegion) with: myEndorsementsDelta with: ((p relevantEndorsements intersect: myNewEndorsements) cast: CrossRegion)]. ^NULL "fodder"! ! !AnyRecorderEFinder methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myPermissions _ receiver receiveHeaper. myEndorsementsDelta _ receiver receiveHeaper. myNewEndorsements _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myPermissions. xmtr sendHeaper: myEndorsementsDelta. xmtr sendHeaper: myNewEndorsements.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AnyRecorderEFinder class instanceVariableNames: ''! (AnyRecorderEFinder getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !AnyRecorderEFinder class methodsFor: 'create'! {PropFinder} make: permissions {IDRegion} with: endorsementsDelta {RegionDelta of: CrossRegion} ^self make: permissions with: endorsementsDelta with: ((endorsementsDelta after minus: endorsementsDelta before) cast: CrossRegion)! {PropFinder} make: permissions {IDRegion} with: endorsementsDelta {RegionDelta of: CrossRegion} with: newEndorsements {CrossRegion} (permissions isEmpty or: [newEndorsements isEmpty]) ifTrue: [^PropFinder closedPropFinder]. ^self create: (SensorCrum flagsFor: permissions with: newEndorsements with: false) with: permissions with: endorsementsDelta with: newEndorsements! !AnyRecorderFinder subclass: #AnyRecorderPFinder instanceVariableNames: ' myPermissionsDelta {RegionDelta of: IDRegion} myPermissions {IDRegion}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Canopy'! AnyRecorderPFinder comment: 'Generates finders for recorders triggered by an increase in permissions'! (AnyRecorderPFinder getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !AnyRecorderPFinder methodsFor: 'accessing'! {BooleanVar} match: prop {Prop} prop cast: SensorProp into: [ :p | ^p relevantPermissions intersects: myPermissions]. ^false "fodder"! {PropFinder} nextFinder: edition {BeEdition} ^ResultRecorderPFinder make: edition with: myPermissionsDelta with: myPermissions with: edition totalEndorsements! {IDRegion} permissions ^myPermissions! {RegionDelta of: IDRegion} permissionsDelta ^myPermissionsDelta! ! !AnyRecorderPFinder methodsFor: 'create'! create: flags {UInt32} with: permissionsDelta {RegionDelta of: IDRegion} with: permissions {IDRegion} super create: flags. myPermissionsDelta := permissionsDelta. myPermissions := permissions.! ! !AnyRecorderPFinder methodsFor: 'testing'! {UInt32} actualHashForEqual ^myPermissionsDelta hashForEqual bitXor: myPermissions hashForEqual! {BooleanVar} isEqual: heaper {Heaper} heaper cast: AnyRecorderPFinder into: [ :other | ^(myPermissionsDelta isEqual: other permissionsDelta) and: [myPermissions isEqual: other permissions]] others: [^false]. ^false "fodder"! ! !AnyRecorderPFinder methodsFor: 'smalltalk: suspended'! {PropFinder} oldPass: parent {PropJoint} parent cast: SensorPropJoint into: [ :p | ^AnyRecorderPFinder make: myPermissionsDelta with: ((p relevantPermissions intersect: myPermissions) cast: IDRegion)]. ^NULL "fodder"! ! !AnyRecorderPFinder methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myPermissionsDelta _ receiver receiveHeaper. myPermissions _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myPermissionsDelta. xmtr sendHeaper: myPermissions.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AnyRecorderPFinder class instanceVariableNames: ''! (AnyRecorderPFinder getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !AnyRecorderPFinder class methodsFor: 'create'! {PropFinder} make: permissionsDelta {RegionDelta of: IDRegion} ^self make: permissionsDelta with: ((permissionsDelta after minus: permissionsDelta before) cast: IDRegion)! {PropFinder} make: permissionsDelta {RegionDelta of: IDRegion} with: newPermissions {IDRegion} newPermissions isEmpty ifTrue: [^PropFinder closedPropFinder]. ^self create: (SensorCrum flagsFor: newPermissions with: NULL with: false) with: permissionsDelta with: newPermissions.! !AbstractRecorderFinder subclass: #CumulativeRecorderFinder instanceVariableNames: ' myGenerators {ImmuSet of: AnyRecorderFinder} myCurrent {ImmuSet of: SimpleRecorderFinder} myOthers {ImmuSet of: SimpleRecorderFinder | AnyRecorderFinder}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Canopy'! CumulativeRecorderFinder comment: 'Propagates a change to all recorders which might be interested in it, and picking up all elements which might newly be made visible by it. The generators make new finders as we pass by additional Edition boundaries. Also holds onto a collection of simple finders looking for recorders triggered by specific Works or Editions. The current set contains those which might record the current edition, and are passed to all Recorders. The others are only passed to Recorders with the directContainersOnly flag off.'! (CumulativeRecorderFinder getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !CumulativeRecorderFinder methodsFor: 'recording'! {void} checkRecorder: recorder {ResultRecorder} with: fossil {RecorderFossil} myCurrent stepper forEach: [ :current {SimpleRecorderFinder} | current checkRecorder: recorder with: fossil]. recorder isDirectOnly ifFalse: [myOthers stepper forEach: [ :other {SimpleRecorderFinder} | other checkRecorder: recorder with: fossil]]! ! !CumulativeRecorderFinder methodsFor: 'create'! create: flags {UInt32} with: generators {ImmuSet of: AnyRecorderFinder} with: current {ImmuSet of: SimpleRecorderFinder} with: others {ImmuSet of: SimpleRecorderFinder | AnyRecorderFinder} super create: flags. myGenerators := generators. myCurrent := current. myOthers := others.! ! !CumulativeRecorderFinder methodsFor: 'accessing'! {ImmuSet of: AnyRecorderFinder} current ^myCurrent! {PropFinder} findPast: edition {BeEdition} | newCurrent {SetAccumulator} | newCurrent := SetAccumulator make. myGenerators stepper forEach: [ :gen {AnyRecorderFinder} | | next {PropFinder} | next := gen nextFinder: edition. next isEmpty ifFalse: [newCurrent step: (next cast: SimpleRecorderFinder) "cast will catch algorithm bugs in a place from which they are easier to fix" ]]. ^CumulativeRecorderFinder make: myGenerators with: (newCurrent value cast: ImmuSet) with: (myOthers unionWith: myCurrent)! {ImmuSet of: AnyRecorderFinder} generators ^myGenerators! {BooleanVar} match: prop {Prop} myGenerators stepper forEach: [ :gen {PropFinder} | (gen match: prop) ifTrue: [^true]]. ^false! {ImmuSet of: SimpleRecorderFinder | AnyRecorderFinder} others ^myOthers! {PropFinder} pass: parent {CanopyCrum} parent cast: SensorCrum into: [ :p | | newGenerators {SetAccumulator} newCurrent {SetAccumulator} newOthers {SetAccumulator} past {PropFinder} | newGenerators := SetAccumulator make. myGenerators stepper forEach: [ :gen {PropFinder} | past := gen pass: p. past isEmpty ifFalse: [newGenerators step: past]]. (newGenerators value cast: ImmuSet) isEmpty ifTrue: [^PropFinder closedPropFinder]. newCurrent := SetAccumulator make. myCurrent stepper forEach: [ :current {PropFinder} | past := current pass: p. past isEmpty ifFalse: [newCurrent step: past]]. newOthers := SetAccumulator make. myOthers stepper forEach: [ :other {PropFinder} | past := other pass: p. past isEmpty ifFalse: [newOthers step: past]]. ^CumulativeRecorderFinder make: (newGenerators value cast: ImmuSet) with: (newCurrent value cast: ImmuSet) with: (newOthers value cast: ImmuSet)]. ^NULL "fodder"! ! !CumulativeRecorderFinder methodsFor: 'testing'! {UInt32} actualHashForEqual ^(myGenerators hashForEqual bitXor: myCurrent hashForEqual) bitXor: myOthers hashForEqual! {BooleanVar} isEqual: heaper {Heaper} heaper cast: CumulativeRecorderFinder into: [ :other | ^(myGenerators isEqual: other generators) and: [(myCurrent isEqual: other current) and: [myOthers isEqual: other others]]] others: [^false]. ^false "fodder"! ! !CumulativeRecorderFinder methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myGenerators _ receiver receiveHeaper. myCurrent _ receiver receiveHeaper. myOthers _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myGenerators. xmtr sendHeaper: myCurrent. xmtr sendHeaper: myOthers.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CumulativeRecorderFinder class instanceVariableNames: ''! (CumulativeRecorderFinder getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !CumulativeRecorderFinder class methodsFor: 'create'! {PropFinder} make: generators {ImmuSet of: SimpleRecorderFinder} with: current {ImmuSet of: SimpleRecorderFinder} with: others {ImmuSet of: SimpleRecorderFinder} | f {UInt32} | generators isEmpty ifTrue: [^PropFinder closedPropFinder]. Ravi thingToDo. "since current & generators can have at most two elements, represent them explicitly as two OR(NULL) pointers? or make special SmallImmuSet class?" f := UInt32Zero. generators stepper forEach: [ :g {AnyRecorderFinder} | f := f bitOr: g flags]. current stepper forEach: [ :c {SimpleRecorderFinder} | f := f bitOr: c flags]. others stepper forEach: [ :o {AbstractRecorderFinder} | f := f bitOr: o flags]. ^self create: f with: generators with: current with: others! !AbstractRecorderFinder subclass: #SimpleRecorderFinder instanceVariableNames: 'myRangeElement {BeRangeElement}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Canopy'! SimpleRecorderFinder comment: 'A finder which holds onto a RangeElement and looks for ResultRecorders which might want to record it NOT.A.TYPE '! (SimpleRecorderFinder getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #COPY; yourself)! !SimpleRecorderFinder methodsFor: 'accessing'! {PropFinder} findPast: edition {BeEdition unused} ^self! {BooleanVar} match: prop {Prop} self subclassResponsibility! ! !SimpleRecorderFinder methodsFor: 'recording'! {void} checkRecorder: recorder {ResultRecorder} with: fossil {RecorderFossil} ((recorder accepts: self rangeElement) and: [self shouldTrigger: recorder with: fossil]) ifTrue: [(RecorderTrigger make: fossil with: myRangeElement) schedule]! {BooleanVar} shouldTrigger: recorder {ResultRecorder} with: fossil {RecorderFossil} "Whether the recorder should be triggered with my RangeElement" self subclassResponsibility! ! !SimpleRecorderFinder methodsFor: 'create'! create super create "for generated code"! create: flags {UInt32} with: element {BeRangeElement} super create: flags. myRangeElement := element.! ! !SimpleRecorderFinder methodsFor: 'protected:'! {BeEdition} edition ^myRangeElement cast: BeEdition! {BeRangeElement} rangeElement ^myRangeElement! {BeWork} work ^myRangeElement cast: BeWork! ! !SimpleRecorderFinder methodsFor: 'smalltalk: suspended'! {PropFinder} oldPass: parent {PropJoint} self subclassResponsibility! ! !SimpleRecorderFinder methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myRangeElement _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myRangeElement.! !SimpleRecorderFinder subclass: #ContainedEditionRecorderEFinder instanceVariableNames: ' myPermissions {IDRegion} myEndorsementsDelta {RegionDelta of: CrossRegion} myNewEndorsements {CrossRegion}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Canopy'! ContainedEditionRecorderEFinder comment: 'Looks for recorders which might be triggered by an increase in endorsements in something containing my edition. Keep the total endorsements on my edition for quick reject?'! (ContainedEditionRecorderEFinder getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !ContainedEditionRecorderEFinder methodsFor: 'recording'! {BooleanVar} shouldTrigger: recorder {ResultRecorder} with: fossil {RecorderFossil} recorder cast: EditionRecorder into: [ :er | [FeServer] USES. CurrentKeyMaster fluidBind: er keyMaster during: [^(er indirectFilter isSwitchedOnBy: myEndorsementsDelta) and: [(er directFilter match: self edition visibleEndorsements) and: [self edition anyPasses: (PropFinder backfollowFinder: er permissionsFilter)]]]]. ^false "fodder"! ! !ContainedEditionRecorderEFinder methodsFor: 'accessing'! {RegionDelta of: CrossRegion} endorsementsDelta ^myEndorsementsDelta! {BooleanVar} match: prop {Prop} prop cast: SensorProp into: [ :p | ^(p relevantPermissions intersects: myPermissions) and: [p relevantEndorsements intersects: myNewEndorsements]]. ^false "fodder"! {CrossRegion} newEndorsements ^myNewEndorsements! {IDRegion} permissions ^myPermissions! ! !ContainedEditionRecorderEFinder methodsFor: 'create'! create: flags {UInt32} with: element {BeRangeElement} with: permissions {IDRegion} with: endorsementsDelta {RegionDelta of: CrossRegion} with: newEndorsements {CrossRegion} super create: flags with: element. myPermissions := permissions. myEndorsementsDelta := endorsementsDelta. myNewEndorsements := newEndorsements.! ! !ContainedEditionRecorderEFinder methodsFor: 'testing'! {UInt32 } actualHashForEqual ^((self rangeElement hashForEqual bitXor: myPermissions hashForEqual) bitXor: myEndorsementsDelta hashForEqual) bitXor: myNewEndorsements hashForEqual! {BooleanVar} isEqual: heaper {Heaper} heaper cast: ContainedEditionRecorderEFinder into: [ :other | ^(self rangeElement isEqual: other rangeElement) and: [(myPermissions isEqual: other permissions) and: [(myEndorsementsDelta isEqual: other endorsementsDelta) and: [myNewEndorsements isEqual: other newEndorsements]]]] others: [^false]. ^ false "compiler fodder"! ! !ContainedEditionRecorderEFinder methodsFor: 'smalltalk: suspended'! {PropFinder} oldPass: parent {PropJoint} parent cast: SensorPropJoint into: [ :p | ^ContainedEditionRecorderEFinder make: self edition with: ((myPermissions intersect: p relevantPermissions) cast: IDRegion) with: myEndorsementsDelta with: ((myNewEndorsements intersect: p relevantEndorsements) cast: CrossRegion)]. ^NULL "fodder"! ! !ContainedEditionRecorderEFinder methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myPermissions _ receiver receiveHeaper. myEndorsementsDelta _ receiver receiveHeaper. myNewEndorsements _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myPermissions. xmtr sendHeaper: myEndorsementsDelta. xmtr sendHeaper: myNewEndorsements.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ContainedEditionRecorderEFinder class instanceVariableNames: ''! (ContainedEditionRecorderEFinder getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !ContainedEditionRecorderEFinder class methodsFor: 'create'! {PropFinder} make: element {BeRangeElement} with: permissions {IDRegion} with: endorsementsDelta {RegionDelta of: CrossRegion} Ravi thingToDo. "Separate out relevant endorsements from new endorsements; relevant is those on contained edition - so you can exclude paths which would never care to record that Edition. At the moment all spawned Contained...Finders will vanish at the same time, i.e. when noone cares about the new endorsements any more. Putting in the relevant endorsements as well allows them to vanish earlier. This could also be done by testing self edition totalEndorsements in match and pass." ^self make: element with: permissions with: endorsementsDelta with: ((endorsementsDelta after minus: endorsementsDelta before) cast: CrossRegion)! {PropFinder} make: element {BeRangeElement} with: permissions {IDRegion} with: endorsementsDelta {RegionDelta of: CrossRegion} with: newEndorsements {CrossRegion} (permissions isEmpty or: [newEndorsements isEmpty]) ifTrue: [^PropFinder closedPropFinder]. ^self create: (SensorCrum flagsFor: permissions with: newEndorsements with: false) with: element with: permissions with: endorsementsDelta with: newEndorsements.! !SimpleRecorderFinder subclass: #OriginalResultRecorderEFinder instanceVariableNames: ' myPermissions {IDRegion} myEndorsementsDelta {RegionDelta of: CrossRegion} myNewEndorsements {CrossRegion}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Canopy'! OriginalResultRecorderEFinder comment: 'Looks for recorders which might be triggered by an increase in endorsements on my RangeElement itself'! (OriginalResultRecorderEFinder getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !OriginalResultRecorderEFinder methodsFor: 'recording'! {BooleanVar} shouldTrigger: recorder {ResultRecorder} with: fossil {RecorderFossil} recorder cast: EditionRecorder into: [ :er | ^(er directFilter isSwitchedOnBy: myEndorsementsDelta) and: [self edition anyPasses: (PropFinder backfollowFinder: er permissionsFilter with: er indirectFilter)]] cast: WorkRecorder into: [ :wr | ^(wr endorsementsFilter isSwitchedOnBy: myEndorsementsDelta) and: [self work canBeReadBy: wr keyMaster]]. ^false "fodder"! ! !OriginalResultRecorderEFinder methodsFor: 'accessing'! {RegionDelta of: CrossRegion} endorsementsDelta ^myEndorsementsDelta! {BooleanVar} match: prop {Prop} prop cast: SensorProp into: [ :p | ^(p relevantEndorsements intersects: myNewEndorsements) and: [p relevantPermissions intersects: myPermissions]]. ^false "fodder"! {CrossRegion} newEndorsements ^myNewEndorsements! {IDRegion} permissions ^myPermissions! ! !OriginalResultRecorderEFinder methodsFor: 'create'! create: flags {UInt32} with: element {BeRangeElement} with: permissions {IDRegion} with: endorsementsDelta {RegionDelta of: CrossRegion} with: newEndorsements {CrossRegion} super create: flags with: element. myPermissions := permissions. myEndorsementsDelta := endorsementsDelta. myNewEndorsements := newEndorsements.! ! !OriginalResultRecorderEFinder methodsFor: 'testing'! {UInt32 } actualHashForEqual ^((self rangeElement hashForEqual bitXor: myPermissions hashForEqual) bitXor: myEndorsementsDelta hashForEqual) bitXor: myNewEndorsements hashForEqual! {BooleanVar} isEqual: heaper {Heaper} heaper cast: OriginalResultRecorderEFinder into: [ :other | ^(self rangeElement isEqual: other rangeElement) and: [(myPermissions isEqual: other permissions) and: [(myEndorsementsDelta isEqual: other endorsementsDelta) and: [myNewEndorsements isEqual: other newEndorsements]]]] others: [^false]. ^ false "compiler fodder"! ! !OriginalResultRecorderEFinder methodsFor: 'smalltalk: suspended'! {PropFinder} oldPass: parent {PropJoint} parent cast: SensorPropJoint into: [ :p | ^OriginalResultRecorderEFinder make: self rangeElement with: ((myPermissions intersect: p relevantPermissions) cast: IDRegion) with: myEndorsementsDelta with: ((myNewEndorsements intersect: p relevantEndorsements) cast: CrossRegion)]. ^NULL "fodder"! ! !OriginalResultRecorderEFinder methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myPermissions _ receiver receiveHeaper. myEndorsementsDelta _ receiver receiveHeaper. myNewEndorsements _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myPermissions. xmtr sendHeaper: myEndorsementsDelta. xmtr sendHeaper: myNewEndorsements.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! OriginalResultRecorderEFinder class instanceVariableNames: ''! (OriginalResultRecorderEFinder getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !OriginalResultRecorderEFinder class methodsFor: 'create'! {PropFinder} make: element {BeRangeElement} with: permissions {IDRegion} with: endorsementsDelta {RegionDelta of: CrossRegion} ^self make: element with: permissions with: endorsementsDelta with: ((endorsementsDelta after minus: endorsementsDelta before) cast: CrossRegion)! {PropFinder} make: element {BeRangeElement} with: permissions {IDRegion} with: endorsementsDelta {RegionDelta of: CrossRegion} with: newEndorsements {CrossRegion} (permissions isEmpty or: [newEndorsements isEmpty]) ifTrue: [^PropFinder closedPropFinder]. ^self create: (SensorCrum flagsFor: permissions with: newEndorsements with: false) with: element with: permissions with: endorsementsDelta with: newEndorsements.! !SimpleRecorderFinder subclass: #ResultRecorderPFinder instanceVariableNames: ' myPermissionsDelta {RegionDelta} myNewPermissions {IDRegion} myEndorsements {CrossRegion}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Canopy'! ResultRecorderPFinder comment: 'Looks for records which might be triggered by in increase in visibility of my RangeElement'! (ResultRecorderPFinder getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !ResultRecorderPFinder methodsFor: 'create'! create: flags {UInt32} with: element {BeRangeElement} with: permissionsDelta {RegionDelta} with: newPermissions {IDRegion} with: endorsements {CrossRegion} super create: flags with: element. myPermissionsDelta := permissionsDelta. myNewPermissions := newPermissions. myEndorsements := endorsements.! ! !ResultRecorderPFinder methodsFor: 'accessing'! {CrossRegion} endorsements ^myEndorsements! {BooleanVar} match: prop {Prop} prop cast: SensorProp into: [ :p | ^(p relevantPermissions intersects: myPermissionsDelta after) and: [p relevantEndorsements intersects: myEndorsements]]. ^false "fodder"! {IDRegion} newPermissions ^myNewPermissions! {RegionDelta of: IDRegion} permissionsDelta ^myPermissionsDelta! ! !ResultRecorderPFinder methodsFor: 'recording'! {BooleanVar} shouldTrigger: recorder {ResultRecorder} with: fossil {RecorderFossil} (recorder permissionsFilter isSwitchedOnBy: myPermissionsDelta) ifTrue: [recorder cast: EditionRecorder into: [ :er | CurrentKeyMaster fluidBind: er keyMaster during: [^er directFilter match: self edition visibleEndorsements]] cast: WorkRecorder into: [ :wr | ^wr endorsementsFilter match: self work endorsements]] ifFalse: [^false]. ^false "fodder"! ! !ResultRecorderPFinder methodsFor: 'testing'! {UInt32} actualHashForEqual ^(myPermissionsDelta hashForEqual bitXor: myNewPermissions hashForEqual) bitXor: myEndorsements hashForEqual! {BooleanVar} isEqual: heaper {Heaper} heaper cast: ResultRecorderPFinder into: [ :other | ^(myPermissionsDelta isEqual: other permissionsDelta) and: [(myNewPermissions isEqual: other newPermissions) and: [myEndorsements isEqual: other endorsements]]] others: [^false]. ^false "fodder"! ! !ResultRecorderPFinder methodsFor: 'smalltalk: suspended'! {PropFinder} oldPass: parent {PropJoint} parent cast: SensorPropJoint into: [ :p | ^ResultRecorderPFinder make: self rangeElement with: myPermissionsDelta with: ((myNewPermissions intersect: p relevantPermissions) cast: IDRegion) with: ((myEndorsements intersect: p relevantEndorsements) cast: CrossRegion)]. ^NULL "fodder"! ! !ResultRecorderPFinder methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myPermissionsDelta _ receiver receiveHeaper. myNewPermissions _ receiver receiveHeaper. myEndorsements _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myPermissionsDelta. xmtr sendHeaper: myNewPermissions. xmtr sendHeaper: myEndorsements.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ResultRecorderPFinder class instanceVariableNames: ''! (ResultRecorderPFinder getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !ResultRecorderPFinder class methodsFor: 'create'! {PropFinder} make: element {BeRangeElement} with: permissionsDelta {RegionDelta} with: endorsements {CrossRegion} ^self make: element with: permissionsDelta with: ((permissionsDelta after minus: permissionsDelta before) cast: IDRegion) with: endorsements.! {PropFinder} make: element {BeRangeElement} with: permissionsDelta {RegionDelta} with: newPermissions {IDRegion} with: endorsements {CrossRegion} (newPermissions isEmpty or: [endorsements isEmpty]) ifTrue: [^PropFinder closedPropFinder]. ^self create: (SensorCrum flagsFor: newPermissions with: endorsements with: false) with: element with: permissionsDelta with: newPermissions with: endorsements.! !SensorPropFinder subclass: #PartialityFinder instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Canopy'! PartialityFinder comment: 'When walking the o-plane to separate out the "partial" part of an Edition, this finder is used to filter the walk according to the sensor canopy.'! (PartialityFinder getOrMakeCxxClassDescription) attributes: ((Set new) add: #COPY; add: #SMALLTALK.ONLY; add: #OBSOLETE; add: #NOT.A.TYPE; add: #CONCRETE; yourself)! !PartialityFinder methodsFor: 'create'! create super create: SensorCrum isPartialFlag! ! !PartialityFinder methodsFor: 'accessing'! {PropFinder} findPast: stamp {BeEdition unused} ^self! {BooleanVar} match: prop {Prop} "tell whether a prop matches this filter" ^(prop cast: SensorProp) isPartial! ! !PartialityFinder methodsFor: 'testing'! {UInt32} actualHashForEqual ^self getCategory hashForEqual! {BooleanVar} isEqual: other {Heaper} ^other isKindOf: PartialityFinder! ! !PartialityFinder methodsFor: 'smalltalk: suspended'! {PropFinder} oldPass: parent {PropJoint} "return a simple enough finder for looking at the children" (parent cast: SensorPropJoint) isPartial ifTrue: [^self] ifFalse: [^PropFinder closedPropFinder]! ! !PartialityFinder methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !Heaper subclass: #ProtocolBroker instanceVariableNames: '' classVariableNames: ' CommProtocols {ProtocolItem} DiskProtocols {ProtocolItem} TheCommProtocol {XcvrMaker} TheDiskProtocol {XcvrMaker} ' poolDictionaries: '' category: 'Xanadu-negoti8'! (ProtocolBroker getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #EQ; yourself)! !ProtocolBroker methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ProtocolBroker class instanceVariableNames: ''! (ProtocolBroker getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #EQ; yourself)! !ProtocolBroker class methodsFor: 'smalltalk: initialization'! linkTimeNonInherited DiskProtocols _ NULL. CommProtocols _ NULL. TheCommProtocol _ NULL. TheDiskProtocol _ NULL! ! !ProtocolBroker class methodsFor: 'configuration'! {XcvrMaker} commProtocol "return whichever is the best current protocol." TheCommProtocol == NULL ifTrue: [TheCommProtocol _ (CommProtocols get: 'binary1') cast: XcvrMaker]. ^TheCommProtocol! {XcvrMaker} commProtocol: id {char star} ^(CommProtocols get: id) cast: XcvrMaker! {XcvrMaker} diskProtocol "return whichever is the best current protocol." TheDiskProtocol == NULL ifTrue: [TheDiskProtocol _ (DiskProtocols get: 'binary1') cast: XcvrMaker]. ^TheDiskProtocol! {XcvrMaker} diskProtocol: id {char star} ^(DiskProtocols get: id) cast: XcvrMaker! {void} registerXcvrProtocol: maker {XcvrMaker} CommProtocols _ ProtocolItem create: maker id with: maker with: CommProtocols. DiskProtocols _ ProtocolItem create: maker id with: maker with: DiskProtocols.! {void} setCommProtocol: maker {XcvrMaker} "Set the protocol." TheCommProtocol _ maker! {void} setDiskProtocol: maker {XcvrMaker} "Set the protocol." TheDiskProtocol _ maker! !Heaper subclass: #ProtocolItem instanceVariableNames: ' myName {char star} myNext {ProtocolItem} myItem {Heaper}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-negoti8'! (ProtocolItem getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !ProtocolItem methodsFor: 'accessing'! {Heaper} get: name {char star} (String strcmp: name with: myName) == Int32Zero ifTrue: [ ^ myItem ]. myNext ~~ NULL ifTrue: [ ^ myNext get: name ] ifFalse: [ Heaper BLAST: #NotInList ]. ^NULL "fodder"! ! !ProtocolItem methodsFor: 'create'! create: name {char star} with: item {Heaper} with: next {ProtocolItem} super create. myName _ name. myItem _ item. myNext _ next! ! !ProtocolItem methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! !Heaper subclass: #Rcvr instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Xcvr'! (Rcvr getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #EQ; yourself)! !Rcvr methodsFor: 'receiving'! {BooleanVar} receiveBooleanVar self subclassResponsibility! {void} receiveData: array {UInt8Array} "Fill the array with data from the stream." self subclassResponsibility! {Heaper} receiveHeaper self subclassResponsibility! {IEEEDoubleVar} receiveIEEEDoubleVar self subclassResponsibility! {Int32} receiveInt32 self subclassResponsibility! {Int8} receiveInt8 self subclassResponsibility! {IntegerVar} receiveIntegerVar self subclassResponsibility! {void} receiveInto: memory {Heaper} "Receive an object into another object." self subclassResponsibility! {char star} receiveString self subclassResponsibility! {UInt32} receiveUInt32 self subclassResponsibility! {UInt8} receiveUInt8 self subclassResponsibility! ! !Rcvr methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! !Rcvr subclass: #SpecialistRcvr instanceVariableNames: ' mySpecialist {TransferSpecialist} myIbids {PtrArray} myNextIbid {Int4}' classVariableNames: 'RcvrIbidCache {PtrArray} ' poolDictionaries: '' category: 'Xanadu-Xcvr'! SpecialistRcvr comment: 'myIbids maps from ibid number to already sent objects. The ibids table is explicitly managed as a PtrArray because it is such a bottleneck.'! (SpecialistRcvr getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !SpecialistRcvr methodsFor: 'receiving'! {BooleanVar} receiveBooleanVar self subclassResponsibility! {Category} receiveCategory "Return a category object using the internal coding that any rcvr must have to represent categories." self subclassResponsibility! {void} receiveData: array {UInt8Array} "Fill the array with data from the stream." self subclassResponsibility! {Heaper} receiveHeaper "receive the next heaper" | cat {Category} | cat _ self fetchStartOfInstance. cat == NULL ifTrue: [^NULL]. (cat isEqual: CommIbid) ifTrue: [| ibidNum {Int32} result {Heaper} | ibidNum _ self receiveInt32. self endOfInstance. result _ myIbids fetch: ibidNum. result == NULL ifTrue: [Heaper BLAST: #NotInTable]. ^result] ifFalse: [| result {Heaper} | result _ mySpecialist receiveHeaper: cat from: self. self endOfInstance. ^result]! {IEEEDoubleVar} receiveIEEEDoubleVar self subclassResponsibility! {Int32} receiveInt32 self subclassResponsibility! {Int8} receiveInt8 self subclassResponsibility! {IntegerVar} receiveIntegerVar self subclassResponsibility! {void} receiveInto: memory {Heaper} "Receive an object into another object." | cat {Category} | cat _ self fetchStartOfInstance. (cat == NULL or: [cat isEqual: CommIbid]) ifTrue: [Heaper BLAST: #NotBecomable]. mySpecialist receiveHeaper: cat into: memory from: self. self endOfInstance! {char star} receiveString self subclassResponsibility! {UInt32} receiveUInt32 self subclassResponsibility! {UInt8} receiveUInt8 self subclassResponsibility! ! !SpecialistRcvr methodsFor: 'specialist receiving'! {Heaper} basicReceive: recipe {Recipe} "Pull the contents of the next heaper off the wire." recipe cast: CopyRecipe into: [:copy | ^copy parse: self] others: [Heaper BLAST: #BadRecipe]. ^NULL! {void} basicReceive: recipe {Recipe} into: memory {Heaper} "Pull the contents of the next heaper off the wire." (memory getCategory canYouBecome: recipe categoryOfDish) ifFalse: [Heaper BLAST: #NotBecomable]. self registerIbid: memory. [memory destructor] smalltalkOnly. recipe cast: CopyRecipe into: [:copy | copy parse: self into: memory] others: [Heaper BLAST: #BadRecipe]! {Heaper} makeIbid: cat {Category} "Create and register a memory slot for an instance of the given category." | result {Heaper} | 'result = (Heaper *)Heaper::operator new (0, xcsj, cat);' translateOnly. [result _ DeletedHeaper create] smalltalkOnly. self registerIbid: result. ^result! {void} registerIbid: obj {Heaper} myNextIbid >= myIbids count ifTrue: ["Grow the table." | oldIbids {PtrArray} | oldIbids _ myIbids. myIbids _ PtrArray nulls: myNextIbid * 2. 1 almostTo: myNextIbid do: [:i {Int32} | myIbids at: i store: (oldIbids fetch: i)]. oldIbids destroy]. myIbids at: myNextIbid store: obj. myNextIbid _ myNextIbid + 1.! ! !SpecialistRcvr methodsFor: 'protected: specialist'! {void} endOfInstance self subclassResponsibility! {void} endPacket Int32Zero almostTo: myNextIbid do: [:i {Int32} | myIbids at: i store: NULL]. myNextIbid _ Int32Zero! {Category} fetchStartOfInstance self subclassResponsibility! {TransferSpecialist} specialist ^mySpecialist! ! !SpecialistRcvr methodsFor: 'protected: creation'! create: specialist {TransferSpecialist} super create. mySpecialist _ specialist. RcvrIbidCache == NULL ifTrue: [myIbids _ PtrArray nulls: 128] ifFalse: [myIbids _ RcvrIbidCache. RcvrIbidCache _ NULL]. myNextIbid _ Int32Zero! {void} destruct RcvrIbidCache == NULL ifTrue: [myIbids storeAll. RcvrIbidCache _ myIbids cast: PtrArray. myIbids _ NULL] ifFalse: [myIbids destroy]. "mySpecialist destroy" super destruct! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! SpecialistRcvr class instanceVariableNames: ''! (SpecialistRcvr getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !SpecialistRcvr class methodsFor: 'smalltalk: init'! linkTimeNonInherited RcvrIbidCache _ NULL! !SpecialistRcvr subclass: #Binary2Rcvr instanceVariableNames: ' myStream {XnReadStream} myDepth {IntegerVar}' classVariableNames: 'SomeRcvrs {InstanceCache} ' poolDictionaries: '' category: 'Xanadu-Xcvr'! (Binary2Rcvr getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !Binary2Rcvr methodsFor: 'receiving'! {BooleanVar} receiveBooleanVar | result {BooleanVar} | self startThing. result _ myStream getByte. self endThing. result == 1 ifTrue: [^true] ifFalse: [result == Int0 ifTrue: [^false] ifFalse: [Heaper BLAST: #InvalidRequest]]. ^false "fodder"! {Category | NULL} receiveCategory | num {IntegerVar} | num _ self getIntegerVar. num == IntegerVar0 ifTrue: [myDepth _ myDepth - 1. self endThing. ^NULL] ifFalse: [^self specialist getCategoryFor: num-1]! {void} receiveData: array {UInt8Array} "Fill the array with data from the stream." self startThing. Int32Zero to: array count - 1 do: [ :i {Int32} | array at: i storeUInt: myStream getByte]. self endThing! {IEEEDoubleVar} receiveIEEEDoubleVar "| result {IEEEDoubleVar} | self startThing. result _ Double make: self getIntegerVar with: self getIntegerVar. self endThing. ^result" self unimplemented. ^NULL! {Int32} receiveInt32 | result {Int32} | self startThing. result _ self getIntegerVar DOTasLong. self endThing. ^result! {Int8} receiveInt8 | result {Int8} | self startThing. result _ myStream getByte. [result > 127 ifTrue: [result _ result - 256]] smalltalkOnly. self endThing. ^result! {IntegerVar} receiveIntegerVar | result {IntegerVar} | self startThing. result _ self getIntegerVar. self endThing. ^result! {char star} receiveString | size {Int32} result {char star} | size _ self getIntegerVar DOTasLong. self startThing. [result _ String streamContents: [ :stream | 1 to: size do: [:ignore {IntegerVar} | stream nextPut: (Character char: myStream getByte)]]] smalltalkOnly. ' result = new char[size+1]; char c; int soFar = 0; for (; soFar < size ; soFar++) { c = myStream->getByte(); result[soFar] = c; } result[soFar] = ''\0'';' translateOnly. self endThing. ^result! {UInt32} receiveUInt32 | result {UInt32} | self startThing. result _ self getIntegerVar DOTasLong. self endThing. ^result! {UInt8} receiveUInt8 | result {UInt8} | self startThing. result _ myStream getByte. self endThing. ^result! ! !Binary2Rcvr methodsFor: 'protected: specialist'! {void} endOfInstance myDepth _ myDepth - 1. self endThing! {void} endPacket myStream getByte == $!! uint8 assert: 'End of packet marker required'. myStream getByte == $!! uint8 assert: 'End of packet marker required'. super endPacket! {Category | NULL} fetchStartOfInstance self startThing. myDepth _ myDepth + 1. ^self receiveCategory! {IntegerVar} getIntegerVar "A new representation that requires less shifting (eventually)." " 7/1 0<7> 14/2 10<6> <8> 21/3 110<5> <16> 28/4 1110<4> <24> 35/5 11110<3> <32> 42/6 111110<2> <40> 49/7 1111110<1> <48> 56/8 11111110 <56> ?/? 11111111 " | byte {UInt8} stream {XnReadStream wimpy} mask {UInt8} count {Int32} num {Int32} | "count is bytes following first word or -1 if bignum meaning next byte is humber for actual count" stream _ self stream. byte _ stream getByte. byte <= 2r00111111 ifTrue: [^byte]. byte <= 2r01111111 ifTrue: [^byte-128]. byte <= 2r10111111 ifTrue: [mask _ 2r00111111. count _ 1] ifFalse: [byte <= 2r11011111 ifTrue: [mask _ 2r00011111. count _ 2] ifFalse: [byte <= 2r11101111 ifTrue: [mask _ 2r00001111. count _ 3] ifFalse: [byte <= 2r11110111 ifTrue: [mask _ 2r00000111. count _ 4] ifFalse: [self unimplemented]]]]. byte _ byte bitAnd: mask. (byte bitAnd: ((mask bitInvert bitShiftRight: 1) bitAnd: mask)) ~= Int32Zero ifTrue: [byte _ byte bitOr: mask bitInvert. num _ -1] ifFalse: [num _ Int32Zero. ((count > 3) and: [(byte ~= (byte bitAnd: mask))]) ifTrue: [self unimplemented]]. num _ (num bitShift: 8) + byte. 1 to: count do: [:i {Int32} | num _ (num bitShift: 8) + stream getByte]. ^ num! ! !Binary2Rcvr methodsFor: 'private:'! {void} endThing myDepth == IntegerVar0 ifTrue: [self endPacket]! {void} startThing myDepth == IntegerVar0 ifTrue: [myStream refill]! ! !Binary2Rcvr methodsFor: 'creation'! create: specialist {TransferSpecialist} with: stream {XnReadStream} super create: specialist. myStream _ stream. myDepth _ IntegerVar0! {void} destroy (SomeRcvrs store: self) ifFalse: [super destroy]! ! !Binary2Rcvr methodsFor: 'smalltalk: deja vu'! {void} getIdentifier: buf {UInt8Array} "get an identifier from the stream into a pre-allocated buffer" | c {char} nextPos {UInt32} limit {UInt32} | [limit _ buf count - 1 "For the NULL at the end."] translateOnly. [limit _ buf count] smalltalkOnly. nextPos _ UInt32Zero. c _ myStream getByte. [(Character isalnum: c) or: [c == $_]] whileTrue: [nextPos >= limit ifTrue: [TextyRcvr blast.IdentifierTooLong raise]. buf at: nextPos store: c uint8. nextPos _ nextPos + 1. c _ Character char: myStream getByte]. myStream putBack: c uint8. [buf at: nextPos store: Int32Zero] translateOnly. [buf become: (PrimSpec uInt8 arrayFromBuffer: nextPos with: buf)] smalltalkOnly.! {void} receiveString: array {UInt8Array} self startThing. [^String streamContents: [ :stream | | c {char} | self getCharToken: $". [$" ~~ (c _ myStream getByte)] whileTrue: [c ~~ $\ ifTrue: [stream nextPut: c] ifFalse: [c _ myStream getByte. c == $' ifTrue: [stream nextPut: $'] ifFalse: [c == $" ifTrue: [stream nextPut: $"] ifFalse: [c == $n ifTrue: [stream nextPut: Character cr] ifFalse: [c == $t ifTrue: [stream nextPut: Character tab] ifFalse: [c == $b ifTrue: [stream nextPut: Character backspace] ifFalse: [self class blast.InvalidCharacter raise]]]]]]]]] smalltalkOnly. [self unimplemented] translateOnly. self endThing! ! !Binary2Rcvr methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '( ' << myStream << ')'! ! !Binary2Rcvr methodsFor: 'protected: accessing'! {XnReadStream INLINE} stream ^ myStream! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Binary2Rcvr class instanceVariableNames: ''! (Binary2Rcvr getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !Binary2Rcvr class methodsFor: 'creation'! {SpecialistRcvr} make: specialist {TransferSpecialist} with: stream {XnReadStream} | result {Heaper} | result := SomeRcvrs fetch. result == NULL ifTrue: [^ self create: specialist with: stream] ifFalse: [^ (self new.Become: result) create: specialist with: stream]! ! !Binary2Rcvr class methodsFor: 'smalltalk: init'! initTimeNonInherited SomeRcvrs := InstanceCache make: 8! linkTimeNonInherited SomeRcvrs := NULL! !SpecialistRcvr subclass: #TextyRcvr instanceVariableNames: ' myStream {XnReadStream} myDepth {IntegerVar}' classVariableNames: ' ReceiveStringBuffer {char vector} ReceiveStringBufferSize {Int4 const} ' poolDictionaries: '' category: 'Xanadu-Xcvr'! (TextyRcvr getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !TextyRcvr methodsFor: 'receiving'! {BooleanVar} receiveBooleanVar | result {BooleanVar} | self startThing. result _ self skipWhiteSpace. self endThing. result == $1 ifTrue: [^true] ifFalse: [result == $0 ifTrue: [^false] ifFalse: [Heaper BLAST: #InvalidRequest]]. ^false "fodder"! {Category} receiveCategory self getIdentifier: ReceiveStringBuffer with: ReceiveStringBufferSize-1. (String strcmp: ReceiveStringBuffer with: 'NULL') == UInt32Zero ifTrue: [self endThing. ^NULL]. [^Category find: (ReceiveStringBuffer copyUpTo: Character null)] smalltalkOnly. ^Category find: ReceiveStringBuffer.! {void} receiveData: array {UInt8Array} "Fill the array with data from the stream." self startThing. self getCharToken: $". Int32Zero almostTo: array count do: [ :i {Int32} | array at: i storeUInt: myStream getByte]. self getCharToken: $". self endThing! {IEEEDoubleVar} receiveIEEEDoubleVar self startThing. self unimplemented. self endThing. ^0.0! {Int32} receiveInt32 | result {Int32} | self startThing. result _ self receiveNumber DOTasLong. self endThing. ^result! {Int8} receiveInt8 | result {Int8} | self startThing. result _ self receiveNumber DOTasInt. self endThing. ^result! {IntegerVar} receiveIntegerVar | result {IntegerVar} | self startThing. result _ self receiveNumber. self endThing. ^result "[^IntegerVar localIntVar: self with: #tcsj] translateOnly."! {char star} receiveString | result {char star} | self startThing. [result _ String streamContents: [ :stream | | c {char} | self getCharToken: $". [$" ~~ (c _ Character char: myStream getByte)] whileTrue: [c ~~ $\ ifTrue: [stream nextPut: c] ifFalse: [c _ myStream getByte. c == $' ifTrue: [stream nextPut: $'] ifFalse: [c == $" ifTrue: [stream nextPut: $"] ifFalse: [c == $n ifTrue: [stream nextPut: Character cr] ifFalse: [c == $t ifTrue: [stream nextPut: Character tab] ifFalse: [c == $b ifTrue: [stream nextPut: Character backspace] ifFalse: [Heaper BLAST: #InvalidCharacter]]]]]]]]] smalltalkOnly. 'char *buf = TextyRcvr::ReceiveStringBuffer; UInt32 max = TextyRcvr::ReceiveStringBufferSize; this->getCharToken(''"''); for (char c = myStream->getByte(); c !!= ''\"''; c = myStream->getByte()) { if (max <= 1) { BLAST(STRING_TOO_LONG); } max -= 1; if (c !!= ''\\'') { *buf++ = c; } else { c = myStream->getByte(); switch (c) { case ''a'': *buf++ = ALERT_CHAR; break; case ''?'': /* ANSI permits, but does not require, ''?'' to be escaped. Therefore, even */ /* though we do not send it escaped, for consistency with the standard, we */ /* can receive it either way. */ *buf++ = ''?''; break; case ''\n'': max += 1; break; case ''n'': *buf++ = ''\n''; break; case ''t'': *buf++ = ''\t''; break; case ''b'': *buf++ = ''\b''; break; case ''r'': *buf++ = ''\r''; break; case ''f'': *buf++ = ''\f''; break; case ''v'': *buf++ = ''\v''; break; case ''\\'': *buf++ = ''\\''; break; case ''\'''': *buf++ = ''\''''; break; case ''\"'': *buf++ = ''\"''; break; default: BLAST(UNRECOGNIZED_ESCAPE); } } } *buf++ = ''\0''; Int32 size = buf - ReceiveStringBuffer; result = strcpy(new char[size],ReceiveStringBuffer);' translateOnly. self endThing. ^result! {UInt32} receiveUInt32 | result {UInt32} | self startThing. result _ self receiveNumber DOTasLong. self endThing. ^result! {UInt8} receiveUInt8 | result {UInt8} | self startThing. result _ self receiveNumber DOTasInt. self endThing. ^result! ! !TextyRcvr methodsFor: 'protected: lexer'! {void} decrementDepth myDepth _ myDepth - 1! {void} endOfInstance self getCharToken: $). myDepth _ myDepth - 1. self endThing! {void} endPacket self getCharToken: $;. super endPacket! {Category} fetchStartOfInstance | cat {Category} | self startThing. cat _ self receiveCategory. cat == NULL ifTrue: [^NULL]. myDepth _ myDepth + 1. self getCharToken: $(. ^cat! {UInt32} getByte ^myStream getByte! {void} getCharToken: referent {Character} "match a character from the input stream" | c {char} | c _ self skipWhiteSpace. c ~~ referent ifTrue: [Heaper BLAST: #WrongCharacter]! {void} getIdentifier: buf {char star} with: limit {Int32} "get an identifier from the stream into a pre-allocated buffer" | c {char} nextPos {Int32} | nextPos _ Int32Zero. c _ self skipWhiteSpace. [(Character isalnum: c) or: [c == $_]] whileTrue: [nextPos >= limit ifTrue: [TextyRcvr BLAST: #IdentifierTooLong]. [buf at: nextPos+1 put: c] smalltalkOnly. [buf at: nextPos put: c] translateOnly. nextPos _ nextPos + 1. c _ Character char: myStream getByte]. myStream putBack: c uint8. [buf at: nextPos+1 put: (Character char: UInt32Zero)] smalltalkOnly. [buf at: nextPos put: (Character char: UInt32Zero)] translateOnly! {void} incrementDepth myDepth _ myDepth + 1! {char} skipWhiteSpace "return the first character following white space" | c {char} | c _ Character char: myStream getByte. [(Character isspace: c) or: [c == $,]] whileTrue: [c _ Character char: myStream getByte]. ^c! ! !TextyRcvr methodsFor: 'private: receiving'! {IntegerVar} receiveNumber "Receive an arbitrary number. Convert to the lesser types by range checking and casting." | value {IntegerVar} neg {BooleanVar} c {UInt8} | c _ self skipWhiteSpace. neg _ c == $-. neg ifTrue: [c _ Character char: myStream getByte]. value _ IntegerVar0. [Character isdigit: c] whileTrue: [| digit {UInt8} | digit _ c uint8 - $0 uint8. value _ value * 10 + digit. c _ Character char: myStream getByte]. myStream putBack: c uint8. neg ifTrue: [^value negated]. ^value! ! !TextyRcvr methodsFor: 'creation'! create: specialist {TransferSpecialist} with: stream {XnReadStream} super create: specialist. myStream _ stream. myDepth _ IntegerVar0! ! !TextyRcvr methodsFor: 'smalltalk: receiving'! {String} receiveEverything ^String streamContents: [ :stream | [myStream atEnd] whileFalse: [stream nextPut: (Character char: myStream getByte)]]! ! !TextyRcvr methodsFor: 'smalltalk: deja vu'! {void} receiveString: array {UInt8Array} self startThing. [^String streamContents: [ :stream | | c {char} | self getCharToken: $". [$" ~~ (c _ myStream getByte)] whileTrue: [c ~~ $\ ifTrue: [stream nextPut: c] ifFalse: [c _ myStream getByte. c == $' ifTrue: [stream nextPut: $'] ifFalse: [c == $" ifTrue: [stream nextPut: $"] ifFalse: [c == $n ifTrue: [stream nextPut: Character cr] ifFalse: [c == $t ifTrue: [stream nextPut: Character tab] ifFalse: [c == $b ifTrue: [stream nextPut: Character backspace] ifFalse: [Heaper BLAST: #InvalidCharacter]]]]]]]]] smalltalkOnly. [self unimplemented] translateOnly. self endThing! ! !TextyRcvr methodsFor: 'protected: receiving'! {void} endThing myDepth == IntegerVar0 ifTrue: [self endPacket]! {void} startThing myDepth == IntegerVar0 ifTrue: [myStream refill]! ! !TextyRcvr methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '( ' << myStream << ')'! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TextyRcvr class instanceVariableNames: ''! (TextyRcvr getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !TextyRcvr class methodsFor: 'creation'! {SpecialistRcvr} make: specialist {TransferSpecialist} with: stream {XnReadStream} ^self create: specialist with: stream! ! !TextyRcvr class methodsFor: 'smalltalk: init'! linkTimeNonInherited "!!!!!!!! This constant size buffer is a bad idea. It's going to get us in trouble." ReceiveStringBufferSize _ 4096. "4088 is longest allowable C++ class name." 'static char permReceiveStringBuffer[4096]; char * TextyRcvr::ReceiveStringBuffer = permReceiveStringBuffer;' translateOnly. [ReceiveStringBuffer := String new: ReceiveStringBufferSize] smalltalkOnly.! !Heaper subclass: #Recipe instanceVariableNames: ' myCat {Category} myNext {Recipe}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Xcvr'! Recipe comment: 'The table of all recipes in the system is maintained in the Cookbook module. Subclasses know how to craete instances of a particular class.'! (Recipe getOrMakeCxxClassDescription) friends: 'friend class Cookbook; friend Int4 addCuisineTo (APTR(Recipe) cuisine, APTR(PtrArray) recipes);'; attributes: ((Set new) add: #NO.GC; add: #DEFERRED; yourself)! !Recipe methodsFor: 'accessing'! {Category} categoryOfDish ^myCat! ! !Recipe methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '(' << myCat << ')'.! ! !Recipe methodsFor: 'testing'! {UInt32} actualHashForEqual ^self categoryOfDish hashForEqual * 701! {BooleanVar} isEqual: other {Heaper} other cast: Recipe into: [:rec | ^rec categoryOfDish isEqual: self categoryOfDish] others: [^false]. ^false! ! !Recipe methodsFor: 'private: accessing'! {Recipe} next "Returnt the next recipe in the receiver's cuisine." ^myNext! ! !Recipe methodsFor: 'protected: creation'! create: cat {Category} with: cuisine {Recipe star vector} "cuisine points to the *variable* in which the receiver should be registered." super create. myCat _ cat. myNext _ cuisine refValue. cuisine refAssign: self! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Recipe class instanceVariableNames: ''! (Recipe getOrMakeCxxClassDescription) friends: 'friend class Cookbook; friend Int4 addCuisineTo (APTR(Recipe) cuisine, APTR(PtrArray) recipes);'; attributes: ((Set new) add: #NO.GC; add: #DEFERRED; yourself)! !Recipe class methodsFor: 'smalltalk: init'! linkTimeNonInherited Recipe star defineGlobal: #XppCuisine with: NULL.! {void} mapCuisine: cxc {CxxClassDescription} "Get a cuisine name from a directory name." | cuisine {char star} | cuisine _ cxc fetchAttribute: #COPY. cuisine == NULL ifTrue: [cuisine _ cxc fetchDirectory notNil: [:d | d key] else: ['Xanadu']]. cuisine := cuisine asString. cuisine = 'xlatexpp' ifTrue: [^'XppCuisine']. cuisine = 'comm' ifTrue: [^'XppCuisine']. cuisine = 'server' ifTrue: [^'DiskCuisine']. cuisine = 'spires' ifTrue: [^'SpireCuisine']. ^cuisine asString asCapitalized, 'Cuisine'! {void} staticTimeNonInherited [Heaper allSubclassesDo: [:cls {Behavior} | cls fetchCxxClassDescription notNil: [:cxc | ((cxc includesAttribute: #COPY) and: [(cxc includesAttribute: #MANUAL.RECIPE) not and: [cxc includesAttribute: #CONCRETE]]) ifTrue: [ActualCopyRecipe create: cls with: (Smalltalk associationAt: (self mapCuisine: cxc) asSymbol ifAbsent: [Association new])]. ((cxc includesAttribute: #PSEUDO.COPY) and: [cxc includesAttribute: #CONCRETE]) ifTrue: [PseudoCopyRecipe create: cls with: (Smalltalk associationAt: (self mapCuisine: cxc) asSymbol ifAbsent: [Association new])]. "(cxc includesAttribute: #BY.PROXY) ifTrue: [| proxy | proxy _ Smalltalk at: (cls name, 'Proxy') asSymbol ifAbsent: []. proxy ~~ nil ifTrue: [ActualProxyRecipe create: proxy with: (Smalltalk associationAt: (self mapCuisine: cxc) asSymbol ifAbsent: [Association new])]]"]]] smalltalkOnly! !Recipe subclass: #CopyRecipe instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cxx-OtherClass'! (CopyRecipe getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !CopyRecipe methodsFor: 'accessing'! {Heaper} parse: rcvr {SpecialistRcvr} "create a new object from the information in the transceiver" | result {void star} | ' result = Heaper::operator new (0, xcsj, this->categoryOfDish());' translateOnly. [result _ DeletedHeaper create] smalltalkOnly. rcvr registerIbid: (result basicCast: Heaper). self parse: rcvr into: result. ^ result basicCast: Heaper.! {void} parse: rcvr {Rcvr} into: memory {void star} "create a new object from the information in the rcvr and give it the identity of memory. The c++ version of this builds the first object received into the area of supplied memory." self subclassResponsibility! ! !CopyRecipe methodsFor: 'protected: creation'! create: cat {Category} with: cuisine {Recipe star vector} "cuisine points to the *variable* in which the receiver should be registered." super create: cat with: cuisine! !CopyRecipe subclass: #CategoryRecipe instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cxx-class-comm'! (CategoryRecipe getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !CategoryRecipe methodsFor: 'accessing'! {Heaper} parse: rcvr {SpecialistRcvr} | cat {Category} | cat _ (rcvr cast: SpecialistRcvr) receiveCategory. rcvr registerIbid: cat. ^cat! {void} parse: rcvr {Rcvr unused} into: memory {void star unused} Heaper BLAST: #NotBecomable! ! !CategoryRecipe methodsFor: 'creation'! create: cat {Category} with: cuisine {Recipe star vector} "cuisine points to the *variable* in which the receiver should be registered." super create: cat with: cuisine! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CategoryRecipe class instanceVariableNames: ''! (CategoryRecipe getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !CategoryRecipe class methodsFor: 'smalltalk: smalltalk initialization'! staticTimeNonInherited 'extern Category * cat_Category; CategoryRecipe categoryRecipe(cat_Category, &XppCuisine);' translateOnly. [self create: Category with: (Smalltalk associationAt: #XppCuisine)] smalltalkOnly! !Recipe subclass: #StubRecipe instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Cxx-class-comm'! (StubRecipe getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !StubRecipe methodsFor: 'accessing'! {Heaper} parseStub: rcvr {Rcvr} with: hash {UInt32} self subclassResponsibility! ! !StubRecipe methodsFor: 'protected: creation'! create: cat {Category} with: cuisine {Recipe star vector} "cuisine points to the *variable* in which the receiver should be registered." super create: cat with: cuisine! !Heaper subclass: #RegionDelta instanceVariableNames: ' myBefore {XnRegion} myAfter {XnRegion}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-filter'! RegionDelta comment: 'A RegionDelta represents a change in the state of a Region, holding the state before and after some change. They are in some sense complementary to Joints: In the same way that you can use Filters to examine Joints, you can use RegionDeltas to examine Filters. See also Filter::isSwitchedBy(RegionDelta *) and related methods.'! (RegionDelta getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !RegionDelta methodsFor: 'creation'! create: before {XnRegion} with: after {XnRegion} super create. myBefore _ before. myAfter _ after! ! !RegionDelta methodsFor: 'testing'! {UInt32} actualHashForEqual ^myBefore hashForEqual + myAfter hashForEqual! {BooleanVar} isEqual: other {Heaper} other cast: RegionDelta into: [:rd | ^(rd before isEqual: myBefore) and: [rd after isEqual: myAfter]] others: [^false]. ^false "fodder"! {BooleanVar INLINE} isSame "if the before and after are the same" ^myBefore isEqual: myAfter! ! !RegionDelta methodsFor: 'accessing'! {XnRegion INLINE} after "The region after the change." ^myAfter! {XnRegion INLINE} before "The region before the change." ^myBefore! ! !RegionDelta methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myBefore _ receiver receiveHeaper. myAfter _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myBefore. xmtr sendHeaper: myAfter.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RegionDelta class instanceVariableNames: ''! (RegionDelta getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !RegionDelta class methodsFor: 'pseudo constructors'! make: before {XnRegion} with: after {XnRegion} ^RegionDelta create: before with: after! !Heaper subclass: #RepairEngineer instanceVariableNames: ' myNext {RepairEngineer} myPrev {RepairEngineer wimpy}' classVariableNames: 'FirstEngineer {RepairEngineer} ' poolDictionaries: '' category: 'Xanadu-gchooks'! RepairEngineer comment: 'RepairEngineers are invoked at the top of server loops and the like in order to perform damage control after such events as a conservative GC or a conservative purge in response to an resource emergency with a deep stack. These modules should implement subclasses of RepairEngineer (RE) which implement the method {void} repair. REs are registered by construction and deregistered by destruction.'! (RepairEngineer getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #EQ; yourself)! !RepairEngineer methodsFor: 'protected: create'! create super create. FirstEngineer ~~ NULL ifTrue: [ FirstEngineer setPrev: self ]. myNext := FirstEngineer. myPrev := NULL. FirstEngineer := self! {void} destruct (myPrev ~~ NULL and: [myPrev isKindOf: RepairEngineer]) ifTrue: [ myPrev setNext: myNext ] ifFalse: [ FirstEngineer := myNext cast: RepairEngineer ]. (myNext ~~ NULL and: [myNext isKindOf: RepairEngineer]) ifTrue: [ myNext setPrev: myPrev ]. super destruct.! ! !RepairEngineer methodsFor: 'invoking'! {void} repair self subclassResponsibility! ! !RepairEngineer methodsFor: 'private: accessing'! {RepairEngineer INLINE} next ^ myNext! {void INLINE} setNext: n {RepairEngineer} myNext := n! {void INLINE} setPrev: n {RepairEngineer} myPrev := n! ! !RepairEngineer methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RepairEngineer class instanceVariableNames: ''! (RepairEngineer getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #EQ; yourself)! !RepairEngineer class methodsFor: 'smalltalk: init'! linkTimeNonInherited FirstEngineer := NULL! ! !RepairEngineer class methodsFor: 'repairing'! {void} repairThings | se {RepairEngineer} | se := FirstEngineer. [se ~~ NULL] whileTrue: [ se repair. se := se next ]! !RepairEngineer subclass: #LiberalPurgeror instanceVariableNames: ' myMustPurge {BooleanVar} myPacker {SnarfPacker}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-purging'! (LiberalPurgeror getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !LiberalPurgeror methodsFor: 'protected: create'! create: packer {SnarfPacker} super create. myPacker := packer. myMustPurge := false! ! !LiberalPurgeror methodsFor: 'accessing'! {void} setMustPurge myMustPurge := true! ! !LiberalPurgeror methodsFor: 'invoking'! {void} repair myMustPurge ifTrue: [myPacker purgeClean: true. myMustPurge := false]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! LiberalPurgeror class instanceVariableNames: ''! (LiberalPurgeror getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !LiberalPurgeror class methodsFor: 'create'! make: packer {SnarfPacker} ^ self create: packer! !Heaper subclass: #RequestHandler instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! RequestHandler comment: 'A class for each abstract signature. Each instance will wrap a pointer to a static member function.'! (RequestHandler getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !RequestHandler methodsFor: 'request handling'! {void} handleRequest: pm {PromiseManager} self subclassResponsibility! ! !RequestHandler methodsFor: 'smalltalk: printing'! printOn: oo | staticFn | staticFn _ self instVarAt: 1. oo << staticFn staticClass << '::' << staticFn selector! ! !RequestHandler methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RequestHandler class instanceVariableNames: ''! (RequestHandler getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !RequestHandler class methodsFor: 'translate: generated'! {void} Adminer.U.acceptConnections.U.N2: receiver {FeAdminer} with: arg1 {BooleanVar} receiver acceptConnections: arg1! {Stepper} Adminer.U.activeSessions.U.N1: receiver {FeAdminer} ^receiver activeSessions! {void} Adminer.U.execute.U.N2: receiver {FeAdminer} with: arg1 {PrimIntArray} receiver execute: arg1! {FeLockSmith} Adminer.U.gateLockSmith.U.N1: receiver {FeAdminer} ^receiver gateLockSmith! {void} Adminer.U.grant.U.N3: receiver {FeAdminer} with: arg1 {ID} with: arg2 {IDRegion} receiver grant: arg1 with: arg2! {TableStepper} Adminer.U.grants.U.N1: receiver {FeAdminer} ^receiver grants! {TableStepper} Adminer.U.grants.U.N2: receiver {FeAdminer} with: arg1 {IDRegion} ^receiver grants: arg1! {TableStepper} Adminer.U.grants.U.N3: receiver {FeAdminer} with: arg1 {IDRegion} with: arg2 {IDRegion} ^receiver grants: arg1 with: arg2! {BooleanVar} Adminer.U.isAcceptingConnections.U.N1: receiver {FeAdminer} ^receiver isAcceptingConnections! {FeAdminer} Adminer.U.make.U.N0 ^FeAdminer make! {void} Adminer.U.setGateLockSmith.U.N2: receiver {FeAdminer} with: arg1 {FeLockSmith} receiver setGateLockSmith: arg1! {FeEdition} Archiver.U.archive.U.N3: receiver {FeArchiver} with: arg1 {FeEdition} with: arg2 {FeEdition} ^receiver archive: arg1 with: arg2! {FeArchiver} Archiver.U.make.U.N0 ^FeArchiver make! {void} Archiver.U.markArchived.U.N2: receiver {FeArchiver} with: arg1 {FeEdition} receiver markArchived: arg1! {FeEdition} Archiver.U.restore.U.N3: receiver {FeArchiver} with: arg1 {FeEdition} with: arg2 {FeEdition} ^receiver restore: arg1 with: arg2! {PrimArray} Array.U.copy.U.N1: receiver {PrimArray} ^receiver copy! {PrimArray} Array.U.copy.U.N2: receiver {PrimArray} with: arg1 {PrimIntValue} ^receiver copy: arg1 asInt32! {PrimArray} Array.U.copy.U.N3: receiver {PrimArray} with: arg1 {PrimIntValue} with: arg2 {PrimIntValue} ^receiver copy: arg1 asInt32 with: arg2 asInt32! {PrimArray} Array.U.copy.U.N4: receiver {PrimArray} with: arg1 {PrimIntValue} with: arg2 {PrimIntValue} with: arg3 {PrimIntValue} ^receiver copy: arg1 asInt32 with: arg2 asInt32 with: arg3 asInt32! {PrimArray} Array.U.copy.U.N5: receiver {PrimArray} with: arg1 {PrimIntValue} with: arg2 {PrimIntValue} with: arg3 {PrimIntValue} with: arg4 {PrimIntValue} ^receiver copy: arg1 asInt32 with: arg2 asInt32 with: arg3 asInt32 with: arg4 asInt32! {PrimIntValue} Array.U.count.U.N1: receiver {PrimArray} ^PrimIntValue make: (receiver count)! {Heaper} Array.U.get.U.N2: receiver {PrimArray} with: arg1 {PrimIntValue} ^receiver getValue: arg1 asInt32! {void} Array.U.store.U.N3: receiver {PrimArray} with: arg1 {PrimIntValue} with: arg2 {Heaper} receiver at: arg1 asInt32 storeValue: arg2! {void} Array.U.storeAll.U.N1: receiver {PrimArray} receiver storeAll! {void} Array.U.storeAll.U.N2: receiver {PrimArray} with: arg1 {Heaper} receiver storeAll: arg1! {void} Array.U.storeAll.U.N3: receiver {PrimArray} with: arg1 {Heaper} with: arg2 {PrimIntValue} receiver storeAll: arg1 with: arg2 asInt32! {void} Array.U.storeAll.U.N4: receiver {PrimArray} with: arg1 {Heaper} with: arg2 {PrimIntValue} with: arg3 {PrimIntValue} receiver storeAll: arg1 with: arg2 asInt32 with: arg3 asInt32! {void} Array.U.storeMany.U.N3: receiver {PrimArray} with: arg1 {PrimIntValue} with: arg2 {PrimArray} receiver at: arg1 asInt32 storeMany: arg2! {void} Array.U.storeMany.U.N4: receiver {PrimArray} with: arg1 {PrimIntValue} with: arg2 {PrimArray} with: arg3 {PrimIntValue} receiver at: arg1 asInt32 storeMany: arg2 with: arg3 asInt32! {void} Array.U.storeMany.U.N5: receiver {PrimArray} with: arg1 {PrimIntValue} with: arg2 {PrimArray} with: arg3 {PrimIntValue} with: arg4 {PrimIntValue} receiver at: arg1 asInt32 storeMany: arg2 with: arg3 asInt32 with: arg4 asInt32! {PrimArray} ArrayBundle.U.array.U.N1: receiver {FeArrayBundle} ^receiver array! {OrderSpec} ArrayBundle.U.ordering.U.N1: receiver {FeArrayBundle} ^receiver ordering! {FeKeyMaster} BooLock.U.boo.U.N1: receiver {BooLock} ^receiver boo! {FeBooLockSmith} BooLockSmith.U.make.U.N0 ^FeBooLockSmith make! {XnRegion} Bundle.U.region.U.N1: receiver {FeBundle} ^receiver region! {PrimIntArray} ChallengeLock.U.challenge.U.N1: receiver {ChallengeLock} ^receiver challenge! {FeKeyMaster} ChallengeLock.U.response.U.N2: receiver {ChallengeLock} with: arg1 {PrimIntArray} ^receiver response: arg1! {PrimIntArray} ChallengeLockSmith.U.encrypterName.U.N1: receiver {FeChallengeLockSmith} ^receiver encrypterName! {FeChallengeLockSmith} ChallengeLockSmith.U.make.U.N2: arg1 {PrimIntArray} with: arg2 {Sequence} ^FeChallengeLockSmith make: arg1 with: arg2! {PrimIntArray} ChallengeLockSmith.U.publicKey.U.N1: receiver {FeChallengeLockSmith} ^receiver publicKey! {FeClub} Club.U.make.U.N1: arg1 {FeEdition} ^FeClub make: arg1! {void} Club.U.removeSignatureClub.U.N1: receiver {FeClub} receiver removeSignatureClub! {void} Club.U.setSignatureClub.U.N2: receiver {FeClub} with: arg1 {ID} receiver setSignatureClub: arg1! {ID} Club.U.signatureClub.U.N1: receiver {FeClub} ^receiver signatureClub! {FeEdition} Club.U.sponsoredWorks.U.N1: receiver {FeClub} ^receiver sponsoredWorks! {FeEdition} Club.U.sponsoredWorks.U.N2: receiver {FeClub} with: arg1 {Filter} ^receiver sponsoredWorks: arg1! {FeLockSmith} ClubDescription.U.lockSmith.U.N1: receiver {FeClubDescription} ^receiver lockSmith! {FeClubDescription} ClubDescription.U.make.U.N2: arg1 {FeSet} with: arg2 {FeLockSmith} ^FeClubDescription make: arg1 with: arg2! {FeSet} ClubDescription.U.membership.U.N1: receiver {FeClubDescription} ^receiver membership! {FeClubDescription} ClubDescription.U.withLockSmith.U.N2: receiver {FeClubDescription} with: arg1 {FeLockSmith} ^receiver withLockSmith: arg1! {FeClubDescription} ClubDescription.U.withMembership.U.N2: receiver {FeClubDescription} with: arg1 {FeSet} ^receiver withMembership: arg1! {OrderSpec} CoordinateSpace.U.ascending.U.N1: receiver {CoordinateSpace} ^receiver ascending! {Mapping} CoordinateSpace.U.completeMapping.U.N2: receiver {CoordinateSpace} with: arg1 {XnRegion} ^receiver completeMapping: arg1! {OrderSpec} CoordinateSpace.U.descending.U.N1: receiver {CoordinateSpace} ^receiver descending! {XnRegion} CoordinateSpace.U.emptyRegion.U.N1: receiver {CoordinateSpace} ^receiver emptyRegion! {XnRegion} CoordinateSpace.U.fullRegion.U.N1: receiver {CoordinateSpace} ^receiver fullRegion! {Mapping} CoordinateSpace.U.identityMapping.U.N1: receiver {CoordinateSpace} ^receiver identityMapping! {Mapping} CrossMapping.U.subMapping.U.N2: receiver {CrossMapping} with: arg1 {PrimIntValue} ^receiver subMapping: arg1 asInt32! {PtrArray} CrossMapping.U.subMappings.U.N1: receiver {CrossMapping} ^receiver subMappings! {PrimIntArray} CrossOrderSpec.U.lexOrder.U.N1: receiver {CrossOrderSpec} ^receiver lexOrder! {OrderSpec} CrossOrderSpec.U.subOrder.U.N2: receiver {CrossOrderSpec} with: arg1 {PrimIntValue} ^receiver subOrder: arg1 asInt32! {PtrArray} CrossOrderSpec.U.subOrders.U.N1: receiver {CrossOrderSpec} ^receiver subOrders! {Stepper} CrossRegion.U.boxes.U.N1: receiver {CrossRegion} ^receiver boxes! {BooleanVar} CrossRegion.U.isBox.U.N1: receiver {CrossRegion} ^receiver isBox! {XnRegion} CrossRegion.U.projection.U.N2: receiver {CrossRegion} with: arg1 {PrimIntValue} ^receiver projection: arg1 asInt32! {PtrArray} CrossRegion.U.projections.U.N1: receiver {CrossRegion} ^receiver projections! {PtrArray} CrossSpace.U.axes.U.N1: receiver {CrossSpace} ^receiver axes! {CoordinateSpace} CrossSpace.U.axis.U.N2: receiver {CrossSpace} with: arg1 {PrimIntValue} ^receiver axis: arg1 asInt32! {PrimIntValue} CrossSpace.U.axisCount.U.N1: receiver {CrossSpace} ^PrimIntValue make: (receiver axisCount)! {Mapping} CrossSpace.U.crossOfMappings.U.N1: receiver {CrossSpace} ^receiver crossOfMappings! {Mapping} CrossSpace.U.crossOfMappings.U.N2: receiver {CrossSpace} with: arg1 {PtrArray} ^receiver crossOfMappings: arg1! {CrossOrderSpec} CrossSpace.U.crossOfOrderSpecs.U.N1: receiver {CrossSpace} ^receiver crossOfOrderSpecs! {CrossOrderSpec} CrossSpace.U.crossOfOrderSpecs.U.N2: receiver {CrossSpace} with: arg1 {PtrArray} ^receiver crossOfOrderSpecs: arg1! {CrossOrderSpec} CrossSpace.U.crossOfOrderSpecs.U.N3: receiver {CrossSpace} with: arg1 {PtrArray} with: arg2 {PrimIntArray} ^receiver crossOfOrderSpecs: arg1 with: arg2! {Tuple} CrossSpace.U.crossOfPositions.U.N2: receiver {CrossSpace} with: arg1 {PtrArray} ^receiver crossOfPositions: arg1! {CrossRegion} CrossSpace.U.crossOfRegions.U.N2: receiver {CrossSpace} with: arg1 {PtrArray} ^receiver crossOfRegions: arg1! {CrossRegion} CrossSpace.U.extrusion.U.N3: receiver {CrossSpace} with: arg1 {PrimIntValue} with: arg2 {XnRegion} ^receiver extrusion: arg1 asInt32 with: arg2! {CrossSpace} CrossSpace.U.make.U.N1: arg1 {PtrArray} ^CrossSpace make: arg1! {FeDataHolder} DataHolder.U.make.U.N1: arg1 {PrimValue} ^FeDataHolder make: arg1! {PrimValue} DataHolder.U.value.U.N1: receiver {FeDataHolder} ^receiver value! {XnRegion} Edition.U.canMakeRangeIdentical.U.N2: receiver {FeEdition} with: arg1 {FeEdition} ^receiver canMakeRangeIdentical: arg1! {XnRegion} Edition.U.canMakeRangeIdentical.U.N3: receiver {FeEdition} with: arg1 {FeEdition} with: arg2 {XnRegion} ^receiver canMakeRangeIdentical: arg1 with: arg2! {FeEdition} Edition.U.combine.U.N2: receiver {FeEdition} with: arg1 {FeEdition} ^receiver combine: arg1! {CoordinateSpace} Edition.U.coordinateSpace.U.N1: receiver {FeEdition} ^receiver coordinateSpace! {FeEdition} Edition.U.copy.U.N2: receiver {FeEdition} with: arg1 {XnRegion} ^receiver copy: arg1! {PrimIntValue} Edition.U.cost.U.N2: receiver {FeEdition} with: arg1 {PrimIntValue} ^PrimIntValue make: (receiver cost: arg1 asInt32)! {PrimIntValue} Edition.U.count.U.N1: receiver {FeEdition} ^PrimIntValue make: (receiver count)! {XnRegion} Edition.U.domain.U.N1: receiver {FeEdition} ^receiver domain! {FeEdition} Edition.U.empty.U.N1: arg1 {CoordinateSpace} ^FeEdition empty: arg1! {void} Edition.U.endorse.U.N2: receiver {FeEdition} with: arg1 {CrossRegion} receiver endorse: arg1! {CrossRegion} Edition.U.endorsements.U.N1: receiver {FeEdition} ^receiver endorsements! {FeEdition} Edition.U.fromAll.U.N2: arg1 {XnRegion} with: arg2 {FeRangeElement} ^FeEdition fromAll: arg1 with: arg2! {FeEdition} Edition.U.fromArray.U.N1: arg1 {PrimArray} ^FeEdition fromArray: arg1! {FeEdition} Edition.U.fromArray.U.N2: arg1 {PrimArray} with: arg2 {XnRegion} ^FeEdition fromArray: arg1 with: arg2! {FeEdition} Edition.U.fromArray.U.N3: arg1 {PrimArray} with: arg2 {XnRegion} with: arg3 {OrderSpec} ^FeEdition fromArray: arg1 with: arg2 with: arg3! {FeEdition} Edition.U.fromOne.U.N2: arg1 {Position} with: arg2 {FeRangeElement} ^FeEdition fromOne: arg1 with: arg2! {FeRangeElement} Edition.U.get.U.N2: receiver {FeEdition} with: arg1 {Position} ^receiver get: arg1! {BooleanVar} Edition.U.hasPosition.U.N2: receiver {FeEdition} with: arg1 {Position} ^receiver hasPosition: arg1! {BooleanVar} Edition.U.isEmpty.U.N1: receiver {FeEdition} ^receiver isEmpty! {BooleanVar} Edition.U.isFinite.U.N1: receiver {FeEdition} ^receiver isFinite! {BooleanVar} Edition.U.isRangeIdentical.U.N2: receiver {FeEdition} with: arg1 {FeEdition} ^receiver isRangeIdentical: arg1! {FeEdition} Edition.U.makeRangeIdentical.U.N2: receiver {FeEdition} with: arg1 {FeEdition} ^receiver makeRangeIdentical: arg1! {FeEdition} Edition.U.makeRangeIdentical.U.N3: receiver {FeEdition} with: arg1 {FeEdition} with: arg2 {XnRegion} ^receiver makeRangeIdentical: arg1 with: arg2! {Mapping} Edition.U.mapSharedOnto.U.N2: receiver {FeEdition} with: arg1 {FeEdition} ^receiver mapSharedOnto: arg1! {Mapping} Edition.U.mapSharedTo.U.N2: receiver {FeEdition} with: arg1 {FeEdition} ^receiver mapSharedTo: arg1! {FeEdition} Edition.U.notSharedWith.U.N2: receiver {FeEdition} with: arg1 {FeEdition} ^receiver notSharedWith: arg1! {FeEdition} Edition.U.notSharedWith.U.N3: receiver {FeEdition} with: arg1 {FeEdition} with: arg2 {PrimIntValue} ^receiver notSharedWith: arg1 with: arg2 asInt32! {FeEdition} Edition.U.placeHolders.U.N1: arg1 {XnRegion} ^FeEdition placeHolders: arg1! {XnRegion} Edition.U.positionsLabelled.U.N2: receiver {FeEdition} with: arg1 {FeLabel} ^receiver positionsLabelled: arg1! {XnRegion} Edition.U.positionsOf.U.N2: receiver {FeEdition} with: arg1 {FeRangeElement} ^receiver positionsOf: arg1! {IDRegion} Edition.U.rangeOwners.U.N2: receiver {FeEdition} with: arg1 {XnRegion} ^receiver rangeOwners: arg1! {FeEdition} Edition.U.rangeTranscluders.U.N1: receiver {FeEdition} ^receiver rangeTranscluders! {FeEdition} Edition.U.rangeTranscluders.U.N2: receiver {FeEdition} with: arg1 {XnRegion} ^receiver rangeTranscluders: arg1! {FeEdition} Edition.U.rangeTranscluders.U.N3: receiver {FeEdition} with: arg1 {XnRegion} with: arg2 {Filter} ^receiver rangeTranscluders: arg1 with: arg2! {FeEdition} Edition.U.rangeTranscluders.U.N4: receiver {FeEdition} with: arg1 {XnRegion} with: arg2 {Filter} with: arg3 {Filter} ^receiver rangeTranscluders: arg1 with: arg2 with: arg3! {FeEdition} Edition.U.rangeTranscluders.U.N5: receiver {FeEdition} with: arg1 {XnRegion} with: arg2 {Filter} with: arg3 {Filter} with: arg4 {PrimIntValue} ^receiver rangeTranscluders: arg1 with: arg2 with: arg3 with: arg4 asInt32! {FeEdition} Edition.U.rangeTranscluders.U.N6: receiver {FeEdition} with: arg1 {XnRegion} with: arg2 {Filter} with: arg3 {Filter} with: arg4 {PrimIntValue} with: arg5 {FeEdition} ^receiver rangeTranscluders: arg1 with: arg2 with: arg3 with: arg4 asInt32 with: arg5! {FeEdition} Edition.U.rangeWorks.U.N1: receiver {FeEdition} ^receiver rangeWorks! {FeEdition} Edition.U.rangeWorks.U.N2: receiver {FeEdition} with: arg1 {XnRegion} ^receiver rangeWorks: arg1! {FeEdition} Edition.U.rangeWorks.U.N3: receiver {FeEdition} with: arg1 {XnRegion} with: arg2 {Filter} ^receiver rangeWorks: arg1 with: arg2! {FeEdition} Edition.U.rangeWorks.U.N4: receiver {FeEdition} with: arg1 {XnRegion} with: arg2 {Filter} with: arg3 {PrimIntValue} ^receiver rangeWorks: arg1 with: arg2 with: arg3 asInt32! {FeEdition} Edition.U.rangeWorks.U.N5: receiver {FeEdition} with: arg1 {XnRegion} with: arg2 {Filter} with: arg3 {PrimIntValue} with: arg4 {FeEdition} ^receiver rangeWorks: arg1 with: arg2 with: arg3 asInt32 with: arg4! {FeEdition} Edition.U.rebind.U.N3: receiver {FeEdition} with: arg1 {Position} with: arg2 {FeEdition} ^receiver rebind: arg1 with: arg2! {FeEdition} Edition.U.replace.U.N2: receiver {FeEdition} with: arg1 {FeEdition} ^receiver replace: arg1! {void} Edition.U.retract.U.N2: receiver {FeEdition} with: arg1 {CrossRegion} receiver retract: arg1! {Stepper} Edition.U.retrieve.U.N1: receiver {FeEdition} ^receiver retrieve! {Stepper} Edition.U.retrieve.U.N2: receiver {FeEdition} with: arg1 {XnRegion} ^receiver retrieve: arg1! {Stepper} Edition.U.retrieve.U.N3: receiver {FeEdition} with: arg1 {XnRegion} with: arg2 {OrderSpec} ^receiver retrieve: arg1 with: arg2! {Stepper} Edition.U.retrieve.U.N4: receiver {FeEdition} with: arg1 {XnRegion} with: arg2 {OrderSpec} with: arg3 {PrimIntValue} ^receiver retrieve: arg1 with: arg2 with: arg3 asInt32! {FeEdition} Edition.U.setRangeOwners.U.N2: receiver {FeEdition} with: arg1 {ID} ^receiver setRangeOwners: arg1! {FeEdition} Edition.U.setRangeOwners.U.N3: receiver {FeEdition} with: arg1 {ID} with: arg2 {XnRegion} ^receiver setRangeOwners: arg1 with: arg2! {XnRegion} Edition.U.sharedRegion.U.N2: receiver {FeEdition} with: arg1 {FeEdition} ^receiver sharedRegion: arg1! {XnRegion} Edition.U.sharedRegion.U.N3: receiver {FeEdition} with: arg1 {FeEdition} with: arg2 {PrimIntValue} ^receiver sharedRegion: arg1 with: arg2 asInt32! {FeEdition} Edition.U.sharedWith.U.N2: receiver {FeEdition} with: arg1 {FeEdition} ^receiver sharedWith: arg1! {FeEdition} Edition.U.sharedWith.U.N3: receiver {FeEdition} with: arg1 {FeEdition} with: arg2 {PrimIntValue} ^receiver sharedWith: arg1 with: arg2 asInt32! {TableStepper} Edition.U.stepper.U.N1: receiver {FeEdition} ^receiver stepper! {TableStepper} Edition.U.stepper.U.N2: receiver {FeEdition} with: arg1 {XnRegion} ^receiver stepper: arg1! {TableStepper} Edition.U.stepper.U.N3: receiver {FeEdition} with: arg1 {XnRegion} with: arg2 {OrderSpec} ^receiver stepper: arg1 with: arg2! {FeRangeElement} Edition.U.theOne.U.N1: receiver {FeEdition} ^receiver theOne! {FeEdition} Edition.U.transformedBy.U.N2: receiver {FeEdition} with: arg1 {Mapping} ^receiver transformedBy: arg1! {CrossRegion} Edition.U.visibleEndorsements.U.N1: receiver {FeEdition} ^receiver visibleEndorsements! {FeEdition} Edition.U.with.U.N3: receiver {FeEdition} with: arg1 {Position} with: arg2 {FeRangeElement} ^receiver with: arg1 with: arg2! {FeEdition} Edition.U.withAll.U.N3: receiver {FeEdition} with: arg1 {XnRegion} with: arg2 {FeRangeElement} ^receiver withAll: arg1 with: arg2! {FeEdition} Edition.U.without.U.N2: receiver {FeEdition} with: arg1 {Position} ^receiver without: arg1! {FeEdition} Edition.U.withoutAll.U.N2: receiver {FeEdition} with: arg1 {XnRegion} ^receiver withoutAll: arg1! {FeRangeElement} ElementBundle.U.element.U.N1: receiver {FeElementBundle} ^receiver element! {XnRegion} Filter.U.baseRegion.U.N1: receiver {Filter} ^receiver baseRegion! {Stepper} Filter.U.intersectedFilters.U.N1: receiver {Filter} ^receiver intersectedFilters! {BooleanVar} Filter.U.isAllFilter.U.N1: receiver {Filter} ^receiver isAllFilter! {BooleanVar} Filter.U.isAnyFilter.U.N1: receiver {Filter} ^receiver isAnyFilter! {BooleanVar} Filter.U.match.U.N2: receiver {Filter} with: arg1 {XnRegion} ^receiver match: arg1! {Stepper} Filter.U.unionedFilters.U.N1: receiver {Filter} ^receiver unionedFilters! {XnRegion} FilterPosition.U.baseRegion.U.N1: receiver {FilterPosition} ^receiver baseRegion! {Filter} FilterSpace.U.allFilter.U.N2: receiver {FilterSpace} with: arg1 {XnRegion} ^receiver allFilter: arg1! {Filter} FilterSpace.U.anyFilter.U.N2: receiver {FilterSpace} with: arg1 {XnRegion} ^receiver anyFilter: arg1! {CoordinateSpace} FilterSpace.U.baseSpace.U.N1: receiver {FilterSpace} ^receiver baseSpace! {FilterSpace} FilterSpace.U.make.U.N1: arg1 {CoordinateSpace} ^FilterSpace make: arg1! {FilterPosition} FilterSpace.U.position.U.N2: receiver {FilterSpace} with: arg1 {XnRegion} ^receiver position: arg1! {PrimIntValue} FloatArray.U.bitCount.U.N1: receiver {PrimFloatArray} ^PrimIntValue make: (receiver bitCount)! {PrimFloatArray} FloatArray.U.zeros.U.N2: arg1 {PrimIntValue} with: arg2 {PrimIntValue} ^PrimFloatArray zeros: arg1 asInt32 with: arg2 asInt32! {PrimIntValue} FloatValue.U.bitCount.U.N1: receiver {PrimFloatValue} ^PrimIntValue make: (receiver bitCount)! {IntegerVarArray} HumberArray.U.zeros.U.N1: arg1 {PrimIntValue} ^IntegerVarArray zeros: arg1 asInt32! {FeHyperRef} HyperLink.U.endAt.U.N2: receiver {FeHyperLink} with: arg1 {Sequence} ^receiver endAt: arg1! {SequenceRegion} HyperLink.U.endNames.U.N1: receiver {FeHyperLink} ^receiver endNames! {FeSet} HyperLink.U.linkTypes.U.N1: receiver {FeHyperLink} ^receiver linkTypes! {FeHyperLink} HyperLink.U.make.U.N3: arg1 {FeSet} with: arg2 {FeHyperRef} with: arg3 {FeHyperRef} ^FeHyperLink make: arg1 with: arg2 with: arg3! {FeHyperLink} HyperLink.U.withEnd.U.N3: receiver {FeHyperLink} with: arg1 {Sequence} with: arg2 {FeHyperRef} ^receiver withEnd: arg1 with: arg2! {FeHyperLink} HyperLink.U.withLinkTypes.U.N2: receiver {FeHyperLink} with: arg1 {FeSet} ^receiver withLinkTypes: arg1! {FeHyperLink} HyperLink.U.withoutEnd.U.N2: receiver {FeHyperLink} with: arg1 {Sequence} ^receiver withoutEnd: arg1! {FeWork} HyperRef.U.originalContext.U.N1: receiver {FeHyperRef} ^receiver originalContext! {FePath} HyperRef.U.pathContext.U.N1: receiver {FeHyperRef} ^receiver pathContext! {FeHyperRef} HyperRef.U.withOriginalContext.U.N2: receiver {FeHyperRef} with: arg1 {FeWork} ^receiver withOriginalContext: arg1! {FeHyperRef} HyperRef.U.withPathContext.U.N2: receiver {FeHyperRef} with: arg1 {FePath} ^receiver withPathContext: arg1! {FeHyperRef} HyperRef.U.withWorkContext.U.N2: receiver {FeHyperRef} with: arg1 {FeWork} ^receiver withWorkContext: arg1! {FeWork} HyperRef.U.workContext.U.N1: receiver {FeHyperRef} ^receiver workContext! {PrimIntArray} ID.U.export.U.N1: receiver {ID} ^receiver export! {ID} ID.U.import.U.N1: arg1 {PrimIntArray} ^ID import: arg1! {ID} IDHolder.U.iD.U.N1: receiver {FeIDHolder} ^receiver iD! {FeIDHolder} IDHolder.U.make.U.N1: arg1 {ID} ^FeIDHolder make: arg1! {PrimIntArray} IDRegion.U.export.U.N1: receiver {IDRegion} ^receiver export! {IDRegion} IDRegion.U.import.U.N1: arg1 {PrimIntArray} ^IDRegion import: arg1! {PrimIntArray} IDSpace.U.export.U.N1: receiver {IDSpace} ^receiver export! {IDSpace} IDSpace.U.global.U.N0 ^IDSpace global! {IDRegion} IDSpace.U.iDsFromServer.U.N2: receiver {IDSpace} with: arg1 {Sequence} ^receiver iDsFromServer: arg1! {IDSpace} IDSpace.U.import.U.N1: arg1 {PrimIntArray} ^IDSpace import: arg1! {ID} IDSpace.U.newID.U.N1: receiver {IDSpace} ^receiver newID! {IDRegion} IDSpace.U.newIDs.U.N2: receiver {IDSpace} with: arg1 {PrimIntValue} ^receiver newIDs: arg1 asIntegerVar! {IDSpace} IDSpace.U.unique.U.N0 ^IDSpace unique! {PrimIntValue} IntArray.U.bitCount.U.N1: receiver {PrimIntArray} ^PrimIntValue make: (receiver bitCount)! {PrimIntArray} IntArray.U.zeros.U.N2: arg1 {PrimIntValue} with: arg2 {PrimIntValue} ^PrimIntArray zeros: arg1 asInt32 with: arg2 asInt32! {PrimIntValue} Integer.U.value.U.N1: receiver {IntegerPos} ^PrimIntValue make: (receiver value)! {PrimIntValue} IntegerMapping.U.translation.U.N1: receiver {IntegerMapping} ^PrimIntValue make: (receiver translation)! {Stepper} IntegerRegion.U.intervals.U.N1: receiver {IntegerRegion} ^receiver intervals! {Stepper} IntegerRegion.U.intervals.U.N2: receiver {IntegerRegion} with: arg1 {OrderSpec} ^receiver intervals: arg1! {BooleanVar} IntegerRegion.U.isBoundedAbove.U.N1: receiver {IntegerRegion} ^receiver isBoundedAbove! {BooleanVar} IntegerRegion.U.isBoundedBelow.U.N1: receiver {IntegerRegion} ^receiver isBoundedBelow! {BooleanVar} IntegerRegion.U.isInterval.U.N1: receiver {IntegerRegion} ^receiver isInterval! {PrimIntValue} IntegerRegion.U.start.U.N1: receiver {IntegerRegion} ^PrimIntValue make: (receiver start)! {PrimIntValue} IntegerRegion.U.stop.U.N1: receiver {IntegerRegion} ^PrimIntValue make: (receiver stop)! {IntegerRegion} IntegerSpace.U.above.U.N2: arg1 {IntegerPos} with: arg2 {BooleanVar} ^IntegerSpace implicitReceiver above: arg1 with: arg2! {IntegerRegion} IntegerSpace.U.below.U.N2: arg1 {IntegerPos} with: arg2 {BooleanVar} ^IntegerSpace implicitReceiver below: arg1 with: arg2! {IntegerRegion} IntegerSpace.U.interval.U.N2: arg1 {IntegerPos} with: arg2 {IntegerPos} ^IntegerSpace implicitReceiver interval: arg1 with: arg2! {IntegerSpace} IntegerSpace.U.make.U.N0 ^IntegerSpace make! {IntegerPos} IntegerSpace.U.position.U.N1: arg1 {PrimIntValue} ^IntegerSpace implicitReceiver position: arg1 asIntegerVar! {IntegerMapping} IntegerSpace.U.translation.U.N1: arg1 {PrimIntValue} ^IntegerSpace implicitReceiver translation: arg1 asIntegerVar! {PrimIntValue} IntValue.U.bitCount.U.N1: receiver {PrimIntValue} ^PrimIntValue make: (receiver bitCount)! {PrimIntValue} IntValue.U.bitwiseAnd.U.N2: receiver {PrimIntValue} with: arg1 {PrimIntValue} ^PrimIntValue make: (receiver bitwiseAnd: arg1)! {PrimIntValue} IntValue.U.bitwiseOr.U.N2: receiver {PrimIntValue} with: arg1 {PrimIntValue} ^PrimIntValue make: (receiver bitwiseOr: arg1)! {PrimIntValue} IntValue.U.bitwiseXor.U.N2: receiver {PrimIntValue} with: arg1 {PrimIntValue} ^PrimIntValue make: (receiver bitwiseXor: arg1)! {PrimIntValue} IntValue.U.dividedBy.U.N2: receiver {PrimIntValue} with: arg1 {PrimIntValue} ^PrimIntValue make: (receiver dividedBy: arg1)! {BooleanVar} IntValue.U.isGE.U.N2: receiver {PrimIntValue} with: arg1 {PrimIntValue} ^receiver isGE: arg1! {PrimIntValue} IntValue.U.leftShift.U.N2: receiver {PrimIntValue} with: arg1 {PrimIntValue} ^PrimIntValue make: (receiver leftShift: arg1)! {PrimIntValue} IntValue.U.maximum.U.N2: receiver {PrimIntValue} with: arg1 {PrimIntValue} ^PrimIntValue make: (receiver maximum: arg1)! {PrimIntValue} IntValue.U.minimum.U.N2: receiver {PrimIntValue} with: arg1 {PrimIntValue} ^PrimIntValue make: (receiver minimum: arg1)! {PrimIntValue} IntValue.U.minus.U.N2: receiver {PrimIntValue} with: arg1 {PrimIntValue} ^PrimIntValue make: (receiver minus: arg1)! {PrimIntValue} IntValue.U.mod.U.N2: receiver {PrimIntValue} with: arg1 {PrimIntValue} ^PrimIntValue make: (receiver mod: arg1)! {PrimIntValue} IntValue.U.plus.U.N2: receiver {PrimIntValue} with: arg1 {PrimIntValue} ^PrimIntValue make: (receiver plus: arg1)! {PrimIntValue} IntValue.U.times.U.N2: receiver {PrimIntValue} with: arg1 {PrimIntValue} ^PrimIntValue make: (receiver times: arg1)! {IDRegion} KeyMaster.U.actualAuthority.U.N1: receiver {FeKeyMaster} ^receiver actualAuthority! {FeKeyMaster} KeyMaster.U.copy.U.N1: receiver {FeKeyMaster} ^receiver copy! {BooleanVar} KeyMaster.U.hasAuthority.U.N2: receiver {FeKeyMaster} with: arg1 {ID} ^receiver hasAuthority: arg1! {void} KeyMaster.U.incorporate.U.N2: receiver {FeKeyMaster} with: arg1 {FeKeyMaster} receiver incorporate: arg1! {IDRegion} KeyMaster.U.loginAuthority.U.N1: receiver {FeKeyMaster} ^receiver loginAuthority! {void} KeyMaster.U.removeLogins.U.N2: receiver {FeKeyMaster} with: arg1 {IDRegion} receiver removeLogins: arg1! {FeLabel} Label.U.make.U.N0 ^FeLabel make! {Mapping} Mapping.U.combine.U.N2: receiver {Mapping} with: arg1 {Mapping} ^receiver combine: arg1! {XnRegion} Mapping.U.domain.U.N1: receiver {Mapping} ^receiver domain! {CoordinateSpace} Mapping.U.domainSpace.U.N1: receiver {Mapping} ^receiver domainSpace! {Mapping} Mapping.U.inverse.U.N1: receiver {Mapping} ^receiver inverse! {BooleanVar} Mapping.U.isComplete.U.N1: receiver {Mapping} ^receiver isComplete! {BooleanVar} Mapping.U.isIdentity.U.N1: receiver {Mapping} ^receiver isIdentity! {Position} Mapping.U.of.U.N2: receiver {Mapping} with: arg1 {Position} ^receiver of: arg1! {XnRegion} Mapping.U.ofAll.U.N2: receiver {Mapping} with: arg1 {XnRegion} ^receiver ofAll: arg1! {XnRegion} Mapping.U.range.U.N1: receiver {Mapping} ^receiver range! {CoordinateSpace} Mapping.U.rangeSpace.U.N1: receiver {Mapping} ^receiver rangeSpace! {Mapping} Mapping.U.restrict.U.N2: receiver {Mapping} with: arg1 {XnRegion} ^receiver restrict: arg1! {Stepper} Mapping.U.simplerMappings.U.N1: receiver {Mapping} ^receiver simplerMappings! {Mapping} Mapping.U.unrestricted.U.N1: receiver {Mapping} ^receiver unrestricted! {FeKeyMaster} MatchLock.U.encryptedPassword.U.N2: receiver {MatchLock} with: arg1 {PrimIntArray} ^receiver encryptedPassword: arg1! {FeMatchLockSmith} MatchLockSmith.U.make.U.N2: arg1 {PrimIntArray} with: arg2 {Sequence} ^FeMatchLockSmith make: arg1 with: arg2! {PrimIntArray} MatchLockSmith.U.scrambledPassword.U.N1: receiver {FeMatchLockSmith} ^receiver scrambledPassword! {PrimIntArray} MatchLockSmith.U.scramblerName.U.N1: receiver {FeMatchLockSmith} ^receiver scramblerName! {Lock} MultiLock.U.lock.U.N2: receiver {MultiLock} with: arg1 {Sequence} ^receiver lock: arg1! {SequenceRegion} MultiLock.U.lockNames.U.N1: receiver {MultiLock} ^receiver lockNames! {FeLockSmith} MultiLockSmith.U.lockSmith.U.N2: receiver {FeMultiLockSmith} with: arg1 {Sequence} ^receiver lockSmith: arg1! {SequenceRegion} MultiLockSmith.U.lockSmithNames.U.N1: receiver {FeMultiLockSmith} ^receiver lockSmithNames! {FeMultiLockSmith} MultiLockSmith.U.make.U.N0 ^FeMultiLockSmith make! {FeMultiLockSmith} MultiLockSmith.U.with.U.N3: receiver {FeMultiLockSmith} with: arg1 {Sequence} with: arg2 {FeLockSmith} ^receiver with: arg1 with: arg2! {FeMultiLockSmith} MultiLockSmith.U.without.U.N2: receiver {FeMultiLockSmith} with: arg1 {Sequence} ^receiver without: arg1! {FeMultiRef} MultiRef.U.intersect.U.N2: receiver {FeMultiRef} with: arg1 {FeMultiRef} ^receiver intersect: arg1! {FeMultiRef} MultiRef.U.make.U.N1: arg1 {PtrArray} ^FeMultiRef make: arg1! {FeMultiRef} MultiRef.U.make.U.N2: arg1 {PtrArray} with: arg2 {FeWork} ^FeMultiRef make: arg1 with: arg2! {FeMultiRef} MultiRef.U.make.U.N3: arg1 {PtrArray} with: arg2 {FeWork} with: arg3 {FeWork} ^FeMultiRef make: arg1 with: arg2 with: arg3! {FeMultiRef} MultiRef.U.make.U.N4: arg1 {PtrArray} with: arg2 {FeWork} with: arg3 {FeWork} with: arg4 {FePath} ^FeMultiRef make: arg1 with: arg2 with: arg3 with: arg4! {FeMultiRef} MultiRef.U.minus.U.N2: receiver {FeMultiRef} with: arg1 {FeMultiRef} ^receiver minus: arg1! {Stepper} MultiRef.U.refs.U.N1: receiver {FeMultiRef} ^receiver refs! {FeMultiRef} MultiRef.U.unionWith.U.N2: receiver {FeMultiRef} with: arg1 {FeMultiRef} ^receiver unionWith: arg1! {FeMultiRef} MultiRef.U.with.U.N2: receiver {FeMultiRef} with: arg1 {FeHyperRef} ^receiver with: arg1! {FeMultiRef} MultiRef.U.without.U.N2: receiver {FeMultiRef} with: arg1 {FeHyperRef} ^receiver without: arg1! {CoordinateSpace} OrderSpec.U.coordinateSpace.U.N1: receiver {OrderSpec} ^receiver coordinateSpace! {BooleanVar} OrderSpec.U.follows.U.N3: receiver {OrderSpec} with: arg1 {Position} with: arg2 {Position} ^receiver follows: arg1 with: arg2! {OrderSpec} OrderSpec.U.reversed.U.N1: receiver {OrderSpec} ^receiver reversed! {FeRangeElement} Path.U.follow.U.N2: receiver {FePath} with: arg1 {FeEdition} ^receiver follow: arg1! {FePath} Path.U.make.U.N1: arg1 {PtrArray} ^FePath make: arg1! {XnRegion} Position.U.asRegion.U.N1: receiver {Position} ^receiver asRegion! {CoordinateSpace} Position.U.coordinateSpace.U.N1: receiver {Position} ^receiver coordinateSpace! {PtrArray} PtrArray.U.nulls.U.N1: arg1 {PrimIntValue} ^PtrArray nulls: arg1 asInt32! {FeRangeElement} RangeElement.U.again.U.N1: receiver {FeRangeElement} ^receiver again! {BooleanVar} RangeElement.U.canMakeIdentical.U.N2: receiver {FeRangeElement} with: arg1 {FeRangeElement} ^receiver canMakeIdentical: arg1! {BooleanVar} RangeElement.U.isIdentical.U.N2: receiver {FeRangeElement} with: arg1 {FeRangeElement} ^receiver isIdentical: arg1! {FeLabel} RangeElement.U.label.U.N1: receiver {FeRangeElement} ^receiver label! {void} RangeElement.U.makeIdentical.U.N2: receiver {FeRangeElement} with: arg1 {FeRangeElement} receiver makeIdentical: arg1! {ID} RangeElement.U.owner.U.N1: receiver {FeRangeElement} ^receiver owner! {FeRangeElement} RangeElement.U.placeHolder.U.N0 ^FeRangeElement placeHolder! {FeRangeElement} RangeElement.U.relabelled.U.N2: receiver {FeRangeElement} with: arg1 {FeLabel} ^receiver relabelled: arg1! {void} RangeElement.U.setOwner.U.N2: receiver {FeRangeElement} with: arg1 {ID} receiver setOwner: arg1! {FeEdition} RangeElement.U.transcluders.U.N1: receiver {FeRangeElement} ^receiver transcluders! {FeEdition} RangeElement.U.transcluders.U.N2: receiver {FeRangeElement} with: arg1 {Filter} ^receiver transcluders: arg1! {FeEdition} RangeElement.U.transcluders.U.N3: receiver {FeRangeElement} with: arg1 {Filter} with: arg2 {Filter} ^receiver transcluders: arg1 with: arg2! {FeEdition} RangeElement.U.transcluders.U.N4: receiver {FeRangeElement} with: arg1 {Filter} with: arg2 {Filter} with: arg3 {PrimIntValue} ^receiver transcluders: arg1 with: arg2 with: arg3 asInt32! {FeEdition} RangeElement.U.transcluders.U.N5: receiver {FeRangeElement} with: arg1 {Filter} with: arg2 {Filter} with: arg3 {PrimIntValue} with: arg4 {FeEdition} ^receiver transcluders: arg1 with: arg2 with: arg3 asInt32 with: arg4! {FeEdition} RangeElement.U.works.U.N1: receiver {FeRangeElement} ^receiver works! {FeEdition} RangeElement.U.works.U.N2: receiver {FeRangeElement} with: arg1 {Filter} ^receiver works: arg1! {FeEdition} RangeElement.U.works.U.N3: receiver {FeRangeElement} with: arg1 {Filter} with: arg2 {PrimIntValue} ^receiver works: arg1 with: arg2 asInt32! {FeEdition} RangeElement.U.works.U.N4: receiver {FeRangeElement} with: arg1 {Filter} with: arg2 {PrimIntValue} with: arg3 {FeEdition} ^receiver works: arg1 with: arg2 asInt32 with: arg3! {PrimFloatValue} Real.U.value.U.N1: receiver {RealPos} ^receiver value! {Stepper} RealRegion.U.intervals.U.N1: receiver {RealRegion} ^receiver intervals! {Stepper} RealRegion.U.intervals.U.N2: receiver {RealRegion} with: arg1 {OrderSpec} ^receiver intervals: arg1! {BooleanVar} RealRegion.U.isBoundedAbove.U.N1: receiver {RealRegion} ^receiver isBoundedAbove! {BooleanVar} RealRegion.U.isBoundedBelow.U.N1: receiver {RealRegion} ^receiver isBoundedBelow! {BooleanVar} RealRegion.U.isInterval.U.N1: receiver {RealRegion} ^receiver isInterval! {RealPos} RealRegion.U.lowerBound.U.N1: receiver {RealRegion} ^receiver lowerBound! {RealPos} RealRegion.U.upperBound.U.N1: receiver {RealRegion} ^receiver upperBound! {RealRegion} RealSpace.U.above.U.N3: receiver {RealSpace} with: arg1 {RealPos} with: arg2 {BooleanVar} ^receiver above: arg1 with: arg2! {RealRegion} RealSpace.U.below.U.N3: receiver {RealSpace} with: arg1 {RealPos} with: arg2 {BooleanVar} ^receiver below: arg1 with: arg2! {RealRegion} RealSpace.U.interval.U.N3: receiver {RealSpace} with: arg1 {RealPos} with: arg2 {RealPos} ^receiver interval: arg1 with: arg2! {RealSpace} RealSpace.U.make.U.N0 ^RealSpace make! {RealPos} RealSpace.U.position.U.N2: receiver {RealSpace} with: arg1 {PrimFloatValue} ^receiver position: arg1 asIEEE64! {XnRegion} Region.U.chooseMany.U.N2: receiver {XnRegion} with: arg1 {PrimIntValue} ^receiver chooseMany: arg1 asIntegerVar! {XnRegion} Region.U.chooseMany.U.N3: receiver {XnRegion} with: arg1 {PrimIntValue} with: arg2 {OrderSpec} ^receiver chooseMany: arg1 asIntegerVar with: arg2! {Position} Region.U.chooseOne.U.N1: receiver {XnRegion} ^receiver chooseOne! {Position} Region.U.chooseOne.U.N2: receiver {XnRegion} with: arg1 {OrderSpec} ^receiver chooseOne: arg1! {XnRegion} Region.U.complement.U.N1: receiver {XnRegion} ^receiver complement! {CoordinateSpace} Region.U.coordinateSpace.U.N1: receiver {XnRegion} ^receiver coordinateSpace! {PrimIntValue} Region.U.count.U.N1: receiver {XnRegion} ^PrimIntValue make: (receiver count)! {BooleanVar} Region.U.hasMember.U.N2: receiver {XnRegion} with: arg1 {Position} ^receiver hasMember: arg1! {XnRegion} Region.U.intersect.U.N2: receiver {XnRegion} with: arg1 {XnRegion} ^receiver intersect: arg1! {BooleanVar} Region.U.intersects.U.N2: receiver {XnRegion} with: arg1 {XnRegion} ^receiver intersects: arg1! {BooleanVar} Region.U.isEmpty.U.N1: receiver {XnRegion} ^receiver isEmpty! {BooleanVar} Region.U.isFinite.U.N1: receiver {XnRegion} ^receiver isFinite! {BooleanVar} Region.U.isFull.U.N1: receiver {XnRegion} ^receiver isFull! {BooleanVar} Region.U.isSubsetOf.U.N2: receiver {XnRegion} with: arg1 {XnRegion} ^receiver isSubsetOf: arg1! {XnRegion} Region.U.minus.U.N2: receiver {XnRegion} with: arg1 {XnRegion} ^receiver minus: arg1! {Stepper} Region.U.stepper.U.N1: receiver {XnRegion} ^receiver stepper! {Stepper} Region.U.stepper.U.N2: receiver {XnRegion} with: arg1 {OrderSpec} ^receiver stepper: arg1! {Position} Region.U.theOne.U.N1: receiver {XnRegion} ^receiver theOne! {XnRegion} Region.U.unionWith.U.N2: receiver {XnRegion} with: arg1 {XnRegion} ^receiver unionWith: arg1! {XnRegion} Region.U.with.U.N2: receiver {XnRegion} with: arg1 {Position} ^receiver with: arg1! {XnRegion} Region.U.without.U.N2: receiver {XnRegion} with: arg1 {Position} ^receiver without: arg1! {PrimIntValue} Sequence.U.firstIndex.U.N1: receiver {Sequence} ^PrimIntValue make: (receiver firstIndex)! {PrimIntValue} Sequence.U.integerAt.U.N2: receiver {Sequence} with: arg1 {PrimIntValue} ^PrimIntValue make: (receiver integerAt: arg1 asIntegerVar)! {PrimArray} Sequence.U.integers.U.N1: receiver {Sequence} ^receiver integers! {BooleanVar} Sequence.U.isZero.U.N1: receiver {Sequence} ^receiver isZero! {PrimIntValue} Sequence.U.lastIndex.U.N1: receiver {Sequence} ^PrimIntValue make: (receiver lastIndex)! {Sequence} Sequence.U.with.U.N3: receiver {Sequence} with: arg1 {PrimIntValue} with: arg2 {PrimIntValue} ^receiver with: arg1 asIntegerVar with: arg2 asIntegerVar! {PrimIntValue} SequenceMapping.U.shift.U.N1: receiver {SequenceMapping} ^PrimIntValue make: (receiver shift)! {Sequence} SequenceMapping.U.translation.U.N1: receiver {SequenceMapping} ^receiver translation! {Stepper} SequenceRegion.U.intervals.U.N1: receiver {SequenceRegion} ^receiver intervals! {Stepper} SequenceRegion.U.intervals.U.N2: receiver {SequenceRegion} with: arg1 {OrderSpec} ^receiver intervals: arg1! {BooleanVar} SequenceRegion.U.isBoundedAbove.U.N1: receiver {SequenceRegion} ^receiver isBoundedAbove! {BooleanVar} SequenceRegion.U.isBoundedBelow.U.N1: receiver {SequenceRegion} ^receiver isBoundedBelow! {BooleanVar} SequenceRegion.U.isInterval.U.N1: receiver {SequenceRegion} ^receiver isInterval! {Sequence} SequenceRegion.U.lowerEdge.U.N1: receiver {SequenceRegion} ^receiver lowerEdge! {PrimIntValue} SequenceRegion.U.lowerEdgePrefixLimit.U.N1: receiver {SequenceRegion} ^PrimIntValue make: (receiver lowerEdgePrefixLimit)! {PrimIntValue} SequenceRegion.U.lowerEdgeType.U.N1: receiver {SequenceRegion} ^PrimIntValue make: (receiver lowerEdgeType)! {Sequence} SequenceRegion.U.upperEdge.U.N1: receiver {SequenceRegion} ^receiver upperEdge! {PrimIntValue} SequenceRegion.U.upperEdgePrefixLimit.U.N1: receiver {SequenceRegion} ^PrimIntValue make: (receiver upperEdgePrefixLimit)! {PrimIntValue} SequenceRegion.U.upperEdgeType.U.N1: receiver {SequenceRegion} ^PrimIntValue make: (receiver upperEdgeType)! {SequenceRegion} SequenceSpace.U.above.U.N2: arg1 {Sequence} with: arg2 {BooleanVar} ^SequenceSpace implicitReceiver above: arg1 with: arg2! {SequenceRegion} SequenceSpace.U.below.U.N2: arg1 {Sequence} with: arg2 {BooleanVar} ^SequenceSpace implicitReceiver below: arg1 with: arg2! {SequenceRegion} SequenceSpace.U.interval.U.N2: arg1 {Sequence} with: arg2 {Sequence} ^SequenceSpace implicitReceiver interval: arg1 with: arg2! {SequenceSpace} SequenceSpace.U.make.U.N0 ^SequenceSpace make! {SequenceMapping} SequenceSpace.U.mapping.U.N1: arg1 {PrimIntValue} ^SequenceSpace implicitReceiver mapping: arg1 asIntegerVar! {SequenceMapping} SequenceSpace.U.mapping.U.N2: arg1 {PrimIntValue} with: arg2 {Sequence} ^SequenceSpace implicitReceiver mapping: arg1 asIntegerVar with: arg2! {Sequence} SequenceSpace.U.position.U.N1: arg1 {PrimArray} ^SequenceSpace implicitReceiver position: arg1! {Sequence} SequenceSpace.U.position.U.N2: arg1 {PrimArray} with: arg2 {PrimIntValue} ^SequenceSpace implicitReceiver position: arg1 with: arg2 asIntegerVar! {SequenceRegion} SequenceSpace.U.prefixedBy.U.N2: arg1 {Sequence} with: arg2 {PrimIntValue} ^SequenceSpace implicitReceiver prefixedBy: arg1 with: arg2 asIntegerVar! {ID} Server.U.accessClubID.U.N0 ^FeServer accessClubID! {ID} Server.U.adminClubID.U.N0 ^FeServer adminClubID! {ID} Server.U.archiveClubID.U.N0 ^FeServer archiveClubID! {ID} Server.U.assignID.U.N1: arg1 {FeRangeElement} ^FeServer assignID: arg1! {ID} Server.U.assignID.U.N2: arg1 {FeRangeElement} with: arg2 {ID} ^FeServer assignID: arg1 with: arg2! {ID} Server.U.clubDirectoryID.U.N0 ^FeServer clubDirectoryID! {PrimIntValue} Server.U.currentTime.U.N0 ^PrimIntValue make: (FeServer currentTime)! {ID} Server.U.emptyClubID.U.N0 ^FeServer emptyClubID! {Sequence} Server.U.encrypterName.U.N0 ^FeServer encrypterName! {FeRangeElement} Server.U.get.U.N1: arg1 {ID} ^FeServer get: arg1! {Sequence} Server.U.identifier.U.N0 ^FeServer identifier! {ID} Server.U.iDOf.U.N1: arg1 {FeRangeElement} ^FeServer iDOf: arg1! {IDRegion} Server.U.iDsOf.U.N1: arg1 {FeRangeElement} ^FeServer iDsOf: arg1! {IDRegion} Server.U.iDsOfRange.U.N1: arg1 {FeEdition} ^FeServer iDsOfRange: arg1! {Lock} Server.U.login.U.N1: arg1 {ID} ^FeServer login: arg1! {Lock} Server.U.loginByName.U.N1: arg1 {Sequence} ^FeServer loginByName: arg1! {ID} Server.U.publicClubID.U.N0 ^FeServer publicClubID! {PrimIntArray} Server.U.publicKey.U.N0 ^FeServer publicKey! {PrimIntValue} Session.U.connectTime.U.N1: receiver {FeSession} ^PrimIntValue make: (receiver connectTime)! {FeSession} Session.U.current.U.N0 ^FeSession current! {void} Session.U.endSession.U.N1: receiver {FeSession} receiver endSession! {void} Session.U.endSession.U.N2: receiver {FeSession} with: arg1 {BooleanVar} receiver endSession: arg1! {ID} Session.U.initialLogin.U.N1: receiver {FeSession} ^receiver initialLogin! {BooleanVar} Session.U.isConnected.U.N1: receiver {FeSession} ^receiver isConnected! {PrimIntArray} Session.U.port.U.N1: receiver {FeSession} ^receiver port! {PrimIntValue} Set.U.count.U.N1: receiver {FeSet} ^PrimIntValue make: (receiver count)! {BooleanVar} Set.U.includes.U.N2: receiver {FeSet} with: arg1 {FeRangeElement} ^receiver includes: arg1! {FeSet} Set.U.intersect.U.N2: receiver {FeSet} with: arg1 {FeSet} ^receiver intersect: arg1! {FeSet} Set.U.make.U.N0 ^FeSet make! {FeSet} Set.U.make.U.N1: arg1 {PtrArray} ^FeSet make: arg1! {FeSet} Set.U.minus.U.N2: receiver {FeSet} with: arg1 {FeSet} ^receiver minus: arg1! {FeRangeElement} Set.U.theOne.U.N1: receiver {FeSet} ^receiver theOne! {FeSet} Set.U.unionWith.U.N2: receiver {FeSet} with: arg1 {FeSet} ^receiver unionWith: arg1! {FeSet} Set.U.with.U.N2: receiver {FeSet} with: arg1 {FeRangeElement} ^receiver with: arg1! {FeSet} Set.U.without.U.N2: receiver {FeSet} with: arg1 {FeRangeElement} ^receiver without: arg1! {FeEdition} SingleRef.U.excerpt.U.N1: receiver {FeSingleRef} ^receiver excerpt! {FeSingleRef} SingleRef.U.make.U.N1: arg1 {FeEdition} ^FeSingleRef make: arg1! {FeSingleRef} SingleRef.U.make.U.N2: arg1 {FeEdition} with: arg2 {FeWork} ^FeSingleRef make: arg1 with: arg2! {FeSingleRef} SingleRef.U.make.U.N3: arg1 {FeEdition} with: arg2 {FeWork} with: arg3 {FeWork} ^FeSingleRef make: arg1 with: arg2 with: arg3! {FeSingleRef} SingleRef.U.make.U.N4: arg1 {FeEdition} with: arg2 {FeWork} with: arg3 {FeWork} with: arg4 {FePath} ^FeSingleRef make: arg1 with: arg2 with: arg3 with: arg4! {FeSingleRef} SingleRef.U.withExcerpt.U.N2: receiver {FeSingleRef} with: arg1 {FeEdition} ^receiver withExcerpt: arg1! {BooleanVar} Stepper.U.atEnd.U.N1: receiver {Stepper} ^receiver atEnd! {Stepper} Stepper.U.copy.U.N1: receiver {Stepper} ^receiver copy! {Heaper} Stepper.U.get.U.N1: receiver {Stepper} ^receiver get! {void} Stepper.U.step.U.N1: receiver {Stepper} receiver step! {PrimArray} Stepper.U.stepMany.U.N1: receiver {Stepper} ^receiver stepMany! {PrimArray} Stepper.U.stepMany.U.N2: receiver {Stepper} with: arg1 {PrimIntValue} ^receiver stepMany: arg1 asInt32! {Heaper} Stepper.U.theOne.U.N1: receiver {Stepper} ^receiver theOne! {Position} TableStepper.U.position.U.N1: receiver {TableStepper} ^receiver position! {PrimArray} TableStepper.U.stepManyPairs.U.N1: receiver {TableStepper} ^receiver stepManyPairs! {PrimArray} TableStepper.U.stepManyPairs.U.N2: receiver {TableStepper} with: arg1 {PrimIntValue} ^receiver stepManyPairs: arg1 asInt32! {FeEdition} Text.U.contents.U.N1: receiver {FeText} ^receiver contents! {PrimIntValue} Text.U.count.U.N1: receiver {FeText} ^PrimIntValue make: (receiver count)! {FeText} Text.U.extract.U.N2: receiver {FeText} with: arg1 {IntegerRegion} ^receiver extract: arg1! {FeText} Text.U.insert.U.N3: receiver {FeText} with: arg1 {PrimIntValue} with: arg2 {FeText} ^receiver insert: arg1 asIntegerVar with: arg2! {FeText} Text.U.make.U.N1: arg1 {PrimArray} ^FeText make: arg1! {FeText} Text.U.move.U.N3: receiver {FeText} with: arg1 {PrimIntValue} with: arg2 {IntegerRegion} ^receiver move: arg1 asIntegerVar with: arg2! {FeText} Text.U.replace.U.N3: receiver {FeText} with: arg1 {IntegerRegion} with: arg2 {FeText} ^receiver replace: arg1 with: arg2! {Position} Tuple.U.coordinate.U.N2: receiver {Tuple} with: arg1 {PrimIntValue} ^receiver coordinate: arg1 asInt32! {PtrArray} Tuple.U.coordinates.U.N1: receiver {Tuple} ^receiver coordinates! {FeWallLockSmith} WallLockSmith.U.make.U.N0 ^FeWallLockSmith make! {BooleanVar} Work.U.canRead.U.N1: receiver {FeWork} ^receiver canRead! {BooleanVar} Work.U.canRevise.U.N1: receiver {FeWork} ^receiver canRevise! {ID} Work.U.editClub.U.N1: receiver {FeWork} ^receiver editClub! {FeEdition} Work.U.edition.U.N1: receiver {FeWork} ^receiver edition! {void} Work.U.endorse.U.N2: receiver {FeWork} with: arg1 {CrossRegion} receiver endorse: arg1! {CrossRegion} Work.U.endorsements.U.N1: receiver {FeWork} ^receiver endorsements! {void} Work.U.grab.U.N1: receiver {FeWork} receiver grab! {ID} Work.U.grabber.U.N1: receiver {FeWork} ^receiver grabber! {ID} Work.U.historyClub.U.N1: receiver {FeWork} ^receiver historyClub! {ID} Work.U.lastRevisionAuthor.U.N1: receiver {FeWork} ^receiver lastRevisionAuthor! {PrimIntValue} Work.U.lastRevisionNumber.U.N1: receiver {FeWork} ^PrimIntValue make: (receiver lastRevisionNumber)! {PrimIntValue} Work.U.lastRevisionTime.U.N1: receiver {FeWork} ^PrimIntValue make: (receiver lastRevisionTime)! {FeWork} Work.U.make.U.N1: arg1 {FeEdition} ^FeWork make: arg1! {ID} Work.U.readClub.U.N1: receiver {FeWork} ^receiver readClub! {void} Work.U.release.U.N1: receiver {FeWork} receiver release! {void} Work.U.removeEditClub.U.N1: receiver {FeWork} receiver removeEditClub! {void} Work.U.removeReadClub.U.N1: receiver {FeWork} receiver removeReadClub! {void} Work.U.requestGrab.U.N1: receiver {FeWork} receiver requestGrab! {void} Work.U.retract.U.N2: receiver {FeWork} with: arg1 {CrossRegion} receiver retract: arg1! {void} Work.U.revise.U.N2: receiver {FeWork} with: arg1 {FeEdition} receiver revise: arg1! {FeEdition} Work.U.revisions.U.N1: receiver {FeWork} ^receiver revisions! {void} Work.U.setEditClub.U.N2: receiver {FeWork} with: arg1 {ID} receiver setEditClub: arg1! {void} Work.U.setHistoryClub.U.N2: receiver {FeWork} with: arg1 {ID} receiver setHistoryClub: arg1! {void} Work.U.setReadClub.U.N2: receiver {FeWork} with: arg1 {ID} receiver setReadClub: arg1! {void} Work.U.sponsor.U.N2: receiver {FeWork} with: arg1 {IDRegion} receiver sponsor: arg1! {IDRegion} Work.U.sponsors.U.N1: receiver {FeWork} ^receiver sponsors! {void} Work.U.unsponsor.U.N2: receiver {FeWork} with: arg1 {IDRegion} receiver unsponsor: arg1! {FeEdition} Wrapper.U.edition.U.N1: receiver {FeWrapper} ^receiver edition! {FeWrapper} Wrapper.U.inner.U.N1: receiver {FeWrapper} ^receiver inner! {Filter} WrapperSpec.U.filter.U.N1: receiver {FeWrapperSpec} ^receiver filter! {FeWrapperSpec} WrapperSpec.U.get.U.N1: arg1 {Sequence} ^FeWrapperSpec get: arg1! {Sequence} WrapperSpec.U.name.U.N1: receiver {FeWrapperSpec} ^receiver name! {FeWrapper} WrapperSpec.U.wrap.U.N2: receiver {FeWrapperSpec} with: arg1 {FeEdition} ^receiver wrap: arg1! !RequestHandler subclass: #BHHandler instanceVariableNames: ' myFn {BHFn var} myType1 {Category}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! (BHHandler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !BHHandler methodsFor: 'request handling'! {void} handleRequest: pm {PromiseManager} | arg1 {Heaper} | arg1 _ pm fetchNonNullHeaper: myType1. pm noErrors ifTrue: [pm respondBooleanVar: (myFn invokeFunction: arg1)]! ! !BHHandler methodsFor: 'creation'! create: fn {BHFn var} with: type1 {Category} super create. myFn _ fn. myType1 _ type1.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BHHandler class instanceVariableNames: ''! (BHHandler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !BHHandler class methodsFor: 'creation'! {RequestHandler} make: fn {BHFn var} with: type1 {Category} ^self create: fn with: type1! ! !BHHandler class methodsFor: 'generated:'! isGenerated ^true! !RequestHandler subclass: #BHHHandler instanceVariableNames: ' myFn {BHHFn var} myType1 {Category} myType2 {Category}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! (BHHHandler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !BHHHandler methodsFor: 'request handling'! {void} handleRequest: pm {PromiseManager} | arg1 {Heaper} arg2 {Heaper} | arg1 _ pm fetchNonNullHeaper: myType1. arg2 _ pm fetchNonNullHeaper: myType2. pm noErrors ifTrue: [pm respondBooleanVar: (myFn invokeFunction: arg1 with: arg2)]! ! !BHHHandler methodsFor: 'creation'! create: fn {BHHFn var} with: type1 {Category} with: type2 {Category} super create. myFn _ fn. myType1 _ type1. myType2 _ type2.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BHHHandler class instanceVariableNames: ''! (BHHHandler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !BHHHandler class methodsFor: 'creation'! {RequestHandler} make: fn {BHHFn var} with: type1 {Category} with: type2 {Category} ^self create: fn with: type1 with: type2! ! !BHHHandler class methodsFor: 'generated:'! isGenerated ^true! !RequestHandler subclass: #BHHHHandler instanceVariableNames: ' myFn {BHHHFn var} myType1 {Category} myType2 {Category} myType3 {Category}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! (BHHHHandler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !BHHHHandler methodsFor: 'request handling'! {void} handleRequest: pm {PromiseManager} | arg1 {Heaper} arg2 {Heaper} arg3 {Heaper} | arg1 _ pm fetchNonNullHeaper: myType1. arg2 _ pm fetchNonNullHeaper: myType2. arg3 _ pm fetchNonNullHeaper: myType3. pm noErrors ifTrue: [pm respondBooleanVar: (myFn invokeFunction: arg1 with: arg2 with: arg3)]! ! !BHHHHandler methodsFor: 'creation'! create: fn {BHHHFn var} with: type1 {Category} with: type2 {Category} with: type3 {Category} super create. myFn _ fn. myType1 _ type1. myType2 _ type2. myType3 _ type3.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BHHHHandler class instanceVariableNames: ''! (BHHHHandler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !BHHHHandler class methodsFor: 'creation'! {RequestHandler} make: fn {BHHHFn var} with: type1 {Category} with: type2 {Category} with: type3 {Category} ^self create: fn with: type1 with: type2 with: type3! ! !BHHHHandler class methodsFor: 'generated:'! isGenerated ^true! !RequestHandler subclass: #ExampleHIHHandler instanceVariableNames: ' myFn {HIHFn} myType2 {Category}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! (ExampleHIHHandler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #SMALLTALK.ONLY; yourself)! !ExampleHIHHandler methodsFor: 'request handling'! {void} handleRequest: pm {PromiseManager} | arg1 {IntegerVar} arg2 {Heaper} | arg1 _ self fetchIntegerVar. arg2 _ self fetchHeaper: myType2. pm noErrors ifTrue: [self respondHeaper: (myFn invokeFunction: arg1 with: arg2)]! ! !ExampleHIHHandler methodsFor: 'creation'! create: fn {HIHFn} with: type2 {Category} super create. myFn _ fn. myType2 _ type2! !RequestHandler subclass: #HHandler instanceVariableNames: 'myFn {HFn var}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! (HHandler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !HHandler methodsFor: 'request handling'! {void} handleRequest: pm {PromiseManager} pm noErrors ifTrue: [pm respondHeaper: (myFn invokeFunction)]! ! !HHandler methodsFor: 'creation'! create: fn {HFn var} super create. myFn _ fn.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HHandler class instanceVariableNames: ''! (HHandler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !HHandler class methodsFor: 'creation'! {RequestHandler} make: fn {HFn var} ^self create: fn! ! !HHandler class methodsFor: 'generated:'! isGenerated ^true! !RequestHandler subclass: #HHBHandler instanceVariableNames: ' myFn {HHBFn var} myType1 {Category}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! (HHBHandler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !HHBHandler methodsFor: 'request handling'! {void} handleRequest: pm {PromiseManager} | arg1 {Heaper} arg2 {BooleanVar} | arg1 _ pm fetchNonNullHeaper: myType1. arg2 _ pm fetchBooleanVar. pm noErrors ifTrue: [pm respondHeaper: (myFn invokeFunction: arg1 with: arg2)]! ! !HHBHandler methodsFor: 'creation'! create: fn {HHBFn var} with: type1 {Category} super create. myFn _ fn. myType1 _ type1.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HHBHandler class instanceVariableNames: ''! (HHBHandler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !HHBHandler class methodsFor: 'creation'! {RequestHandler} make: fn {HHBFn var} with: type1 {Category} ^self create: fn with: type1! ! !HHBHandler class methodsFor: 'generated:'! isGenerated ^true! !RequestHandler subclass: #HHHandler instanceVariableNames: ' myFn {HHFn var} myType1 {Category}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! (HHHandler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !HHHandler methodsFor: 'request handling'! {void} handleRequest: pm {PromiseManager} | arg1 {Heaper} | arg1 _ pm fetchNonNullHeaper: myType1. pm noErrors ifTrue: [pm respondHeaper: (myFn invokeFunction: arg1)]! ! !HHHandler methodsFor: 'creation'! create: fn {HHFn var} with: type1 {Category} super create. myFn _ fn. myType1 _ type1.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HHHandler class instanceVariableNames: ''! (HHHandler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !HHHandler class methodsFor: 'creation'! {RequestHandler} make: fn {HHFn var} with: type1 {Category} ^self create: fn with: type1! ! !HHHandler class methodsFor: 'generated:'! isGenerated ^true! !RequestHandler subclass: #HHHBHandler instanceVariableNames: ' myFn {HHHBFn var} myType1 {Category} myType2 {Category}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! (HHHBHandler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !HHHBHandler methodsFor: 'request handling'! {void} handleRequest: pm {PromiseManager} | arg1 {Heaper} arg2 {Heaper} arg3 {BooleanVar} | arg1 _ pm fetchNonNullHeaper: myType1. arg2 _ pm fetchNonNullHeaper: myType2. arg3 _ pm fetchBooleanVar. pm noErrors ifTrue: [pm respondHeaper: (myFn invokeFunction: arg1 with: arg2 with: arg3)]! ! !HHHBHandler methodsFor: 'creation'! create: fn {HHHBFn var} with: type1 {Category} with: type2 {Category} super create. myFn _ fn. myType1 _ type1. myType2 _ type2.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HHHBHandler class instanceVariableNames: ''! (HHHBHandler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !HHHBHandler class methodsFor: 'creation'! {RequestHandler} make: fn {HHHBFn var} with: type1 {Category} with: type2 {Category} ^self create: fn with: type1 with: type2! ! !HHHBHandler class methodsFor: 'generated:'! isGenerated ^true! !RequestHandler subclass: #HHHHandler instanceVariableNames: ' myFn {HHHFn var} myType1 {Category} myType2 {Category}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! (HHHHandler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !HHHHandler methodsFor: 'request handling'! {void} handleRequest: pm {PromiseManager} | arg1 {Heaper} arg2 {Heaper} | arg1 _ pm fetchNonNullHeaper: myType1. arg2 _ pm fetchNonNullHeaper: myType2. pm noErrors ifTrue: [pm respondHeaper: (myFn invokeFunction: arg1 with: arg2)]! ! !HHHHandler methodsFor: 'creation'! create: fn {HHHFn var} with: type1 {Category} with: type2 {Category} super create. myFn _ fn. myType1 _ type1. myType2 _ type2.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HHHHandler class instanceVariableNames: ''! (HHHHandler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !HHHHandler class methodsFor: 'creation'! {RequestHandler} make: fn {HHHFn var} with: type1 {Category} with: type2 {Category} ^self create: fn with: type1 with: type2! ! !HHHHandler class methodsFor: 'generated:'! isGenerated ^true! !RequestHandler subclass: #HHHHHandler instanceVariableNames: ' myFn {HHHHFn var} myType1 {Category} myType2 {Category} myType3 {Category}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! (HHHHHandler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !HHHHHandler methodsFor: 'request handling'! {void} handleRequest: pm {PromiseManager} | arg1 {Heaper} arg2 {Heaper} arg3 {Heaper} | arg1 _ pm fetchNonNullHeaper: myType1. arg2 _ pm fetchNonNullHeaper: myType2. arg3 _ pm fetchNonNullHeaper: myType3. pm noErrors ifTrue: [pm respondHeaper: (myFn invokeFunction: arg1 with: arg2 with: arg3)]! ! !HHHHHandler methodsFor: 'creation'! create: fn {HHHHFn var} with: type1 {Category} with: type2 {Category} with: type3 {Category} super create. myFn _ fn. myType1 _ type1. myType2 _ type2. myType3 _ type3.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HHHHHandler class instanceVariableNames: ''! (HHHHHandler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !HHHHHandler class methodsFor: 'creation'! {RequestHandler} make: fn {HHHHFn var} with: type1 {Category} with: type2 {Category} with: type3 {Category} ^self create: fn with: type1 with: type2 with: type3! ! !HHHHHandler class methodsFor: 'generated:'! isGenerated ^true! !RequestHandler subclass: #HHHHHHandler instanceVariableNames: ' myFn {HHHHHFn var} myType1 {Category} myType2 {Category} myType3 {Category} myType4 {Category}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! (HHHHHHandler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !HHHHHHandler methodsFor: 'request handling'! {void} handleRequest: pm {PromiseManager} | arg1 {Heaper} arg2 {Heaper} arg3 {Heaper} arg4 {Heaper} | arg1 _ pm fetchNonNullHeaper: myType1. arg2 _ pm fetchNonNullHeaper: myType2. arg3 _ pm fetchNonNullHeaper: myType3. arg4 _ pm fetchNonNullHeaper: myType4. pm noErrors ifTrue: [pm respondHeaper: (myFn invokeFunction: arg1 with: arg2 with: arg3 with: arg4)]! ! !HHHHHHandler methodsFor: 'creation'! create: fn {HHHHHFn var} with: type1 {Category} with: type2 {Category} with: type3 {Category} with: type4 {Category} super create. myFn _ fn. myType1 _ type1. myType2 _ type2. myType3 _ type3. myType4 _ type4.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HHHHHHandler class instanceVariableNames: ''! (HHHHHHandler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !HHHHHHandler class methodsFor: 'creation'! {RequestHandler} make: fn {HHHHHFn var} with: type1 {Category} with: type2 {Category} with: type3 {Category} with: type4 {Category} ^self create: fn with: type1 with: type2 with: type3 with: type4! ! !HHHHHHandler class methodsFor: 'generated:'! isGenerated ^true! !RequestHandler subclass: #HHHHHHHandler instanceVariableNames: ' myFn {HHHHHHFn var} myType1 {Category} myType2 {Category} myType3 {Category} myType4 {Category} myType5 {Category}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! (HHHHHHHandler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !HHHHHHHandler methodsFor: 'request handling'! {void} handleRequest: pm {PromiseManager} | arg1 {Heaper} arg2 {Heaper} arg3 {Heaper} arg4 {Heaper} arg5 {Heaper} | arg1 _ pm fetchNonNullHeaper: myType1. arg2 _ pm fetchNonNullHeaper: myType2. arg3 _ pm fetchNonNullHeaper: myType3. arg4 _ pm fetchNonNullHeaper: myType4. arg5 _ pm fetchNonNullHeaper: myType5. pm noErrors ifTrue: [pm respondHeaper: (myFn invokeFunction: arg1 with: arg2 with: arg3 with: arg4 with: arg5)]! ! !HHHHHHHandler methodsFor: 'creation'! create: fn {HHHHHHFn var} with: type1 {Category} with: type2 {Category} with: type3 {Category} with: type4 {Category} with: type5 {Category} super create. myFn _ fn. myType1 _ type1. myType2 _ type2. myType3 _ type3. myType4 _ type4. myType5 _ type5.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HHHHHHHandler class instanceVariableNames: ''! (HHHHHHHandler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !HHHHHHHandler class methodsFor: 'creation'! {RequestHandler} make: fn {HHHHHHFn var} with: type1 {Category} with: type2 {Category} with: type3 {Category} with: type4 {Category} with: type5 {Category} ^self create: fn with: type1 with: type2 with: type3 with: type4 with: type5! ! !HHHHHHHandler class methodsFor: 'generated:'! isGenerated ^true! !RequestHandler subclass: #HHHHHHHHandler instanceVariableNames: ' myFn {HHHHHHHFn var} myType1 {Category} myType2 {Category} myType3 {Category} myType4 {Category} myType5 {Category} myType6 {Category}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! (HHHHHHHHandler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !HHHHHHHHandler methodsFor: 'request handling'! {void} handleRequest: pm {PromiseManager} | arg1 {Heaper} arg2 {Heaper} arg3 {Heaper} arg4 {Heaper} arg5 {Heaper} arg6 {Heaper} | arg1 _ pm fetchNonNullHeaper: myType1. arg2 _ pm fetchNonNullHeaper: myType2. arg3 _ pm fetchNonNullHeaper: myType3. arg4 _ pm fetchNonNullHeaper: myType4. arg5 _ pm fetchNonNullHeaper: myType5. arg6 _ pm fetchNonNullHeaper: myType6. pm noErrors ifTrue: [pm respondHeaper: (myFn invokeFunction: arg1 with: arg2 with: arg3 with: arg4 with: arg5 with: arg6)]! ! !HHHHHHHHandler methodsFor: 'creation'! create: fn {HHHHHHHFn var} with: type1 {Category} with: type2 {Category} with: type3 {Category} with: type4 {Category} with: type5 {Category} with: type6 {Category} super create. myFn _ fn. myType1 _ type1. myType2 _ type2. myType3 _ type3. myType4 _ type4. myType5 _ type5. myType6 _ type6.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HHHHHHHHandler class instanceVariableNames: ''! (HHHHHHHHandler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !HHHHHHHHandler class methodsFor: 'creation'! {RequestHandler} make: fn {HHHHHHHFn var} with: type1 {Category} with: type2 {Category} with: type3 {Category} with: type4 {Category} with: type5 {Category} with: type6 {Category} ^self create: fn with: type1 with: type2 with: type3 with: type4 with: type5 with: type6! ! !HHHHHHHHandler class methodsFor: 'generated:'! isGenerated ^true! !RequestHandler subclass: #SpecialHandler instanceVariableNames: 'myFn {VHFn var}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! (SpecialHandler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !SpecialHandler methodsFor: 'request handling'! {void} handleRequest: pm {PromiseManager} myFn invokeFunction: pm! ! !SpecialHandler methodsFor: 'creation'! create: fn {VHFn var} super create. myFn _ fn.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! SpecialHandler class instanceVariableNames: ''! (SpecialHandler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !SpecialHandler class methodsFor: 'creation'! {RequestHandler} make: fn {VHFn var} ^ self create: fn! !RequestHandler subclass: #VHBHandler instanceVariableNames: ' myFn {VHBFn var} myType1 {Category}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! (VHBHandler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !VHBHandler methodsFor: 'request handling'! {void} handleRequest: pm {PromiseManager} | arg1 {Heaper} arg2 {BooleanVar} | arg1 _ pm fetchNonNullHeaper: myType1. arg2 _ pm fetchBooleanVar. pm noErrors ifTrue: [(myFn invokeFunction: arg1 with: arg2). pm respondVoid]! ! !VHBHandler methodsFor: 'creation'! create: fn {VHBFn var} with: type1 {Category} super create. myFn _ fn. myType1 _ type1.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! VHBHandler class instanceVariableNames: ''! (VHBHandler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !VHBHandler class methodsFor: 'creation'! {RequestHandler} make: fn {VHBFn var} with: type1 {Category} ^self create: fn with: type1! ! !VHBHandler class methodsFor: 'generated:'! isGenerated ^true! !RequestHandler subclass: #VHHandler instanceVariableNames: ' myFn {VHFn var} myType1 {Category}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! (VHHandler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !VHHandler methodsFor: 'request handling'! {void} handleRequest: pm {PromiseManager} | arg1 {Heaper} | arg1 _ pm fetchNonNullHeaper: myType1. pm noErrors ifTrue: [(myFn invokeFunction: arg1). pm respondVoid]! ! !VHHandler methodsFor: 'creation'! create: fn {VHFn var} with: type1 {Category} super create. myFn _ fn. myType1 _ type1.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! VHHandler class instanceVariableNames: ''! (VHHandler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !VHHandler class methodsFor: 'creation'! {RequestHandler} make: fn {VHFn var} with: type1 {Category} ^self create: fn with: type1! ! !VHHandler class methodsFor: 'generated:'! isGenerated ^true! !RequestHandler subclass: #VHHHandler instanceVariableNames: ' myFn {VHHFn var} myType1 {Category} myType2 {Category}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! (VHHHandler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !VHHHandler methodsFor: 'request handling'! {void} handleRequest: pm {PromiseManager} | arg1 {Heaper} arg2 {Heaper} | arg1 _ pm fetchNonNullHeaper: myType1. arg2 _ pm fetchNonNullHeaper: myType2. pm noErrors ifTrue: [(myFn invokeFunction: arg1 with: arg2). pm respondVoid]! ! !VHHHandler methodsFor: 'creation'! create: fn {VHHFn var} with: type1 {Category} with: type2 {Category} super create. myFn _ fn. myType1 _ type1. myType2 _ type2.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! VHHHandler class instanceVariableNames: ''! (VHHHandler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !VHHHandler class methodsFor: 'creation'! {RequestHandler} make: fn {VHHFn var} with: type1 {Category} with: type2 {Category} ^self create: fn with: type1 with: type2! ! !VHHHandler class methodsFor: 'generated:'! isGenerated ^true! !RequestHandler subclass: #VHHHHandler instanceVariableNames: ' myFn {VHHHFn var} myType1 {Category} myType2 {Category} myType3 {Category}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! (VHHHHandler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !VHHHHandler methodsFor: 'request handling'! {void} handleRequest: pm {PromiseManager} | arg1 {Heaper} arg2 {Heaper} arg3 {Heaper} | arg1 _ pm fetchNonNullHeaper: myType1. arg2 _ pm fetchNonNullHeaper: myType2. arg3 _ pm fetchNonNullHeaper: myType3. pm noErrors ifTrue: [(myFn invokeFunction: arg1 with: arg2 with: arg3). pm respondVoid]! ! !VHHHHandler methodsFor: 'creation'! create: fn {VHHHFn var} with: type1 {Category} with: type2 {Category} with: type3 {Category} super create. myFn _ fn. myType1 _ type1. myType2 _ type2. myType3 _ type3.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! VHHHHandler class instanceVariableNames: ''! (VHHHHandler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !VHHHHandler class methodsFor: 'creation'! {RequestHandler} make: fn {VHHHFn var} with: type1 {Category} with: type2 {Category} with: type3 {Category} ^self create: fn with: type1 with: type2 with: type3! ! !VHHHHandler class methodsFor: 'generated:'! isGenerated ^true! !RequestHandler subclass: #VHHHHHandler instanceVariableNames: ' myFn {VHHHHFn var} myType1 {Category} myType2 {Category} myType3 {Category} myType4 {Category}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! (VHHHHHandler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !VHHHHHandler methodsFor: 'request handling'! {void} handleRequest: pm {PromiseManager} | arg1 {Heaper} arg2 {Heaper} arg3 {Heaper} arg4 {Heaper} | arg1 _ pm fetchNonNullHeaper: myType1. arg2 _ pm fetchNonNullHeaper: myType2. arg3 _ pm fetchNonNullHeaper: myType3. arg4 _ pm fetchNonNullHeaper: myType4. pm noErrors ifTrue: [(myFn invokeFunction: arg1 with: arg2 with: arg3 with: arg4). pm respondVoid]! ! !VHHHHHandler methodsFor: 'creation'! create: fn {VHHHHFn var} with: type1 {Category} with: type2 {Category} with: type3 {Category} with: type4 {Category} super create. myFn _ fn. myType1 _ type1. myType2 _ type2. myType3 _ type3. myType4 _ type4.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! VHHHHHandler class instanceVariableNames: ''! (VHHHHHandler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !VHHHHHandler class methodsFor: 'creation'! {RequestHandler} make: fn {VHHHHFn var} with: type1 {Category} with: type2 {Category} with: type3 {Category} with: type4 {Category} ^self create: fn with: type1 with: type2 with: type3 with: type4! ! !VHHHHHandler class methodsFor: 'generated:'! isGenerated ^true! !RequestHandler subclass: #VHHHHHHandler instanceVariableNames: ' myFn {VHHHHHFn var} myType1 {Category} myType2 {Category} myType3 {Category} myType4 {Category} myType5 {Category}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! (VHHHHHHandler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !VHHHHHHandler methodsFor: 'request handling'! {void} handleRequest: pm {PromiseManager} | arg1 {Heaper} arg2 {Heaper} arg3 {Heaper} arg4 {Heaper} arg5 {Heaper} | arg1 _ pm fetchNonNullHeaper: myType1. arg2 _ pm fetchNonNullHeaper: myType2. arg3 _ pm fetchNonNullHeaper: myType3. arg4 _ pm fetchNonNullHeaper: myType4. arg5 _ pm fetchNonNullHeaper: myType5. pm noErrors ifTrue: [(myFn invokeFunction: arg1 with: arg2 with: arg3 with: arg4 with: arg5). pm respondVoid]! ! !VHHHHHHandler methodsFor: 'creation'! create: fn {VHHHHHFn var} with: type1 {Category} with: type2 {Category} with: type3 {Category} with: type4 {Category} with: type5 {Category} super create. myFn _ fn. myType1 _ type1. myType2 _ type2. myType3 _ type3. myType4 _ type4. myType5 _ type5.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! VHHHHHHandler class instanceVariableNames: ''! (VHHHHHHandler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !VHHHHHHandler class methodsFor: 'creation'! {RequestHandler} make: fn {VHHHHHFn var} with: type1 {Category} with: type2 {Category} with: type3 {Category} with: type4 {Category} with: type5 {Category} ^self create: fn with: type1 with: type2 with: type3 with: type4 with: type5! ! !VHHHHHHandler class methodsFor: 'generated:'! isGenerated ^true! !Heaper subclass: #ResultRecorder instanceVariableNames: ' myPermissionsFilter {Filter} myEndorsementsFilter {Filter} myRelevantEndorsements {CrossRegion} myKeyMaster {FeKeyMaster} myTrailBlazer {TrailBlazer}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-backrec'! ResultRecorder comment: 'Represents the persistent embodiment of a query operation. Can be stored on disk in the form of a RecorderFossil. The abstract protocol deals with: - caching previous results to avoid duplication - storing results in a trail at unique positions - managing persistent permissions - looking for immediate results - checking whether a good candidate (identified by the canopy props) should really go into the trail'! (ResultRecorder getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #EQ; yourself)! !ResultRecorder methodsFor: 'accessing'! {BooleanVar} accepts: element {BeRangeElement} "Whether this recorder accepts this kind of RangeElement" self subclassResponsibility! {IDRegion} actualAuthority ^myKeyMaster actualAuthority! {PropFinder} bertPropFinder "Something to find potential candidates given a source for the query" ^PropFinder backfollowFinder: self permissionsFilter with: self endorsementsFilter! {Filter} endorsementsFilter "The endorsements I am looking for" ^myEndorsementsFilter! {BooleanVar} isDirectOnly "Whether the recorder is for a query with the directContainersOnly flag" self subclassResponsibility! {FeKeyMaster} keyMaster ^myKeyMaster! {Filter of: ID} permissionsFilter "The permissions I am looking for" ^myPermissionsFilter! {SensorProp} sensorProp "A SensorProp which corresponds to what I am looking for" ^SensorProp make: (self permissionsFilter relevantRegion cast: IDRegion) with: myRelevantEndorsements with: false! ! !ResultRecorder methodsFor: 'recording'! {void} record: answer {BeRangeElement} "tell my TrailBlazer to recorder it" myTrailBlazer record: answer! {void} triggerIfMatching: finder {PropFinder} with: fossil {RecorderFossil} "Trigger myself if I match the finder's profile" finder cast: AbstractRecorderFinder into: [ :arf | arf checkRecorder: self with: fossil]! ! !ResultRecorder methodsFor: 'create'! create: endorsementsFilter {Filter} with: relevantEndorsements {CrossRegion} with: trailBlazer {TrailBlazer} super create. Ravi thingToDo. "decide whether this should have a filter or just the relevant regions" myEndorsementsFilter := endorsementsFilter. myRelevantEndorsements := relevantEndorsements. myKeyMaster := CurrentKeyMaster fluidGet. [BeGrandMap] USES. myPermissionsFilter := CurrentGrandMap fluidGet globalIDFilterSpace anyFilter: myKeyMaster actualAuthority. myTrailBlazer := trailBlazer! ! !ResultRecorder methodsFor: 'backfollow'! {void} delayedStoreBackfollow: edition {BeEdition} with: finder {PropFinder} with: fossil {RecorderFossil} with: hCrumCache {HashSetCache of: HistoryCrum} "The immediate part of the backfollow has reached an Edition while traversing northwards. I now get to decide what to do next." self subclassResponsibility! {void} delayedStoreMatching: element {BeRangeElement} with: finder {PropFinder} with: fossil {RecorderFossil} with: hCrumCache {HashSetCache of: HistoryCrum} "The immediate part of the backfollow has reached an RangeElement of the original Edition. I now get to decide what to do next to continue the operation" element delayedStoreBackfollow: finder with: fossil with: self with: hCrumCache "this is a default implementation, which subclasses may override or modify"! ! !ResultRecorder methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! !ResultRecorder subclass: #EditionRecorder instanceVariableNames: ' myDirectFilter {Filter} myIndirectFilter {Filter}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-backrec'! EditionRecorder comment: 'Represents the a persistent transcluders or rangeTranscluders query'! (EditionRecorder getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !EditionRecorder methodsFor: 'accessing'! {BooleanVar} accepts: element {BeRangeElement} ^element isKindOf: BeEdition! {Filter} directFilter ^myDirectFilter! {Filter} indirectFilter ^myIndirectFilter! {BooleanVar} isDirectOnly self subclassResponsibility! ! !EditionRecorder methodsFor: 'create'! create: directFilter {Filter} with: indirectFilter {Filter} with: trailBlazer {TrailBlazer} super create: ((directFilter unionWith: indirectFilter) cast: Filter) with: ((directFilter relevantRegion unionWith: indirectFilter relevantRegion ) cast: CrossRegion) with: trailBlazer. myDirectFilter := directFilter. myIndirectFilter := indirectFilter.! ! !EditionRecorder methodsFor: 'backfollow'! {void} delayedStoreBackfollow: edition {BeEdition} with: finder {PropFinder unused} with: fossil {RecorderFossil} with: hCrumCache {HashSetCache of: HistoryCrum unused} CurrentKeyMaster fluidBind: self keyMaster during: [((myDirectFilter match: edition visibleEndorsements) and: [edition anyPasses: (PropFinder backfollowFinder: self permissionsFilter with: myIndirectFilter)]) ifTrue: [(RecorderTrigger make: fossil with: edition) schedule]]! !EditionRecorder subclass: #DirectEditionRecorder instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-backrec'! DirectEditionRecorder comment: 'Represents the a persistent transcluders or rangeTranscluders query with directContainersOnly flag on'! (DirectEditionRecorder getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !DirectEditionRecorder methodsFor: 'accessing'! {BooleanVar} isDirectOnly ^true! ! !DirectEditionRecorder methodsFor: 'create'! create: directFilter {Filter} with: indirectFilter {Filter} with: trailBlazer {TrailBlazer} super create: directFilter with: indirectFilter with: trailBlazer! !EditionRecorder subclass: #IndirectEditionRecorder instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-backrec'! IndirectEditionRecorder comment: 'Represents the a persistent transcluders or rangeTranscluders query with directContainersOnly flag off'! (IndirectEditionRecorder getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !IndirectEditionRecorder methodsFor: 'accessing'! {BooleanVar} isDirectOnly ^false! ! !IndirectEditionRecorder methodsFor: 'create'! create: directFilter {Filter} with: indirectFilter {Filter} with: trailBlazer {TrailBlazer} super create: directFilter with: indirectFilter with: trailBlazer! ! !IndirectEditionRecorder methodsFor: 'backfollow'! {void} delayedStoreBackfollow: edition {BeEdition} with: finder {PropFinder} with: fossil {RecorderFossil} with: hCrumCache {HashSetCache of: HistoryCrum} super delayedStoreBackfollow: edition with: finder with: fossil with: hCrumCache. edition delayedStoreBackfollow: finder with: fossil with: self with: hCrumCache.! !ResultRecorder subclass: #WorkRecorder instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-backrec'! WorkRecorder comment: 'Represents the a persistent works or rangeWorks query'! (WorkRecorder getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !WorkRecorder methodsFor: 'create'! create: endorsementsFilter {Filter} with: trailBlazer {TrailBlazer} super create: endorsementsFilter with: (endorsementsFilter relevantRegion cast: CrossRegion) with: trailBlazer! ! !WorkRecorder methodsFor: 'accessing'! {BooleanVar} accepts: element {BeRangeElement} ^element isKindOf: BeWork! {BooleanVar} isDirectOnly self subclassResponsibility! ! !WorkRecorder methodsFor: 'backfollow'! {void} delayedStoreBackfollow: edition {BeEdition} with: finder {PropFinder} with: fossil {RecorderFossil} with: hCrumCache {HashSetCache of: HistoryCrum} self subclassResponsibility! {void} recordImmediateWorks: element {BeRangeElement} with: fossil {RecorderFossil} "If there are any Works directly on the RangeElement which pass the filters, record them" element cast: BeEdition into: [ :edition | edition currentWorks stepper forEach: [ :work {BeWork} | ((work canBeReadBy: self keyMaster) and: [self endorsementsFilter match: work endorsements]) ifTrue: [(RecorderTrigger make: fossil with: work) schedule]]] others: []! !WorkRecorder subclass: #DirectWorkRecorder instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-backrec'! DirectWorkRecorder comment: 'Represents the a persistent works or rangeWorks query with the directContainersOnly flag on'! (DirectWorkRecorder getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !DirectWorkRecorder methodsFor: 'create'! create: endorsementsFilter {Filter} with: trailBlazer {TrailBlazer} super create: endorsementsFilter with: trailBlazer! ! !DirectWorkRecorder methodsFor: 'accessing'! {BooleanVar} isDirectOnly ^true! ! !DirectWorkRecorder methodsFor: 'backfollow'! {void} delayedStoreBackfollow: edition {BeEdition unused} with: finder {PropFinder unused} with: fossil {RecorderFossil unused} with: hCrumCache {HashSetCache unused of: HistoryCrum } Heaper BLAST: #FatalError. "This algorithm should never reach here"! {void} delayedStoreMatching: element {BeRangeElement} with: finder {PropFinder unused} with: fossil {RecorderFossil} with: hCrumCache {HashSetCache unused of: HistoryCrum } self recordImmediateWorks: element with: fossil "and nothing else"! !WorkRecorder subclass: #IndirectWorkRecorder instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-backrec'! IndirectWorkRecorder comment: 'Represents the a persistent works or rangeWorks query with the directContainersOnly flag off'! (IndirectWorkRecorder getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !IndirectWorkRecorder methodsFor: 'create'! create: endorsementsFilter {Filter} with: trailBlazer {TrailBlazer} super create: endorsementsFilter with: trailBlazer! ! !IndirectWorkRecorder methodsFor: 'accessing'! {BooleanVar} isDirectOnly ^false! ! !IndirectWorkRecorder methodsFor: 'backfollow'! {void} delayedStoreBackfollow: edition {BeEdition} with: finder {PropFinder} with: fossil {RecorderFossil} with: hCrumCache {HashSetCache of: HistoryCrum} self recordImmediateWorks: edition with: fossil. edition delayedStoreBackfollow: finder with: fossil with: self with: hCrumCache! {void} delayedStoreMatching: element {BeRangeElement} with: finder {PropFinder} with: fossil {RecorderFossil} with: hCrumCache {HashSetCache of: HistoryCrum} self recordImmediateWorks: element with: fossil. super delayedStoreMatching: element with: finder with: fossil with: hCrumCache! !XnExecutor subclass: #RevisionDetectorExecutor instanceVariableNames: 'myWork {FeWork}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-nkernel'! RevisionDetectorExecutor comment: 'This class informs its work when its last detector has gone away.'! (RevisionDetectorExecutor getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !RevisionDetectorExecutor methodsFor: 'protected: create'! create: work {FeWork} super create. myWork := work! ! !RevisionDetectorExecutor methodsFor: 'execute'! {void} execute: arg {Int32} arg == Int32Zero ifTrue: [ myWork removeLastRevisionDetector]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RevisionDetectorExecutor class instanceVariableNames: ''! (RevisionDetectorExecutor getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !RevisionDetectorExecutor class methodsFor: 'create'! {XnExecutor} make: work {FeWork} ^ self create: work! !XnExecutor subclass: #RevisionWatcherExecutor instanceVariableNames: 'myWork {BeWork}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-brange2'! RevisionWatcherExecutor comment: 'This executor tells its BeWork when the last of its revision watchers have gone away.'! (RevisionWatcherExecutor getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !RevisionWatcherExecutor methodsFor: 'protected: create'! create: work {BeWork} super create. myWork := work! ! !RevisionWatcherExecutor methodsFor: 'execute'! {void} execute: arg {Int32} arg == Int32Zero ifTrue: [ myWork removeLastRevisionWatcher]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RevisionWatcherExecutor class instanceVariableNames: ''! (RevisionWatcherExecutor getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !RevisionWatcherExecutor class methodsFor: 'create'! {XnExecutor} make: work {BeWork} ^ self create: work! !Heaper subclass: #SanitationEngineer instanceVariableNames: ' myNext {SanitationEngineer} myPrev {SanitationEngineer wimpy}' classVariableNames: 'FirstEngineer {SanitationEngineer} ' poolDictionaries: '' category: 'Xanadu-gchooks'! SanitationEngineer comment: 'SanitationEngineers are used by modules that can perform clever resource management at garbage collection time. These modules should implement subclasses of SanitationEngineer (SE) which implement the method {void} recycle. The garbage collector calls the recycle method for each existing SE prior to the marking phase. SEs are registered by construction and deregistered by destruction.'! (SanitationEngineer getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #EQ; yourself)! !SanitationEngineer methodsFor: 'invoking'! {void} recycle: required {BooleanVar} self subclassResponsibility! ! !SanitationEngineer methodsFor: 'protected: create'! create super create. FirstEngineer ~~ NULL ifTrue: [ FirstEngineer setPrev: self ]. myNext := FirstEngineer. myPrev := NULL. FirstEngineer := self! {void} destruct (myPrev ~~ NULL and: [myPrev isKindOf: SanitationEngineer]) ifTrue: [ myPrev setNext: myNext ] ifFalse: [ FirstEngineer := myNext cast: SanitationEngineer ]. (myNext ~~ NULL and: [myNext isKindOf: SanitationEngineer]) ifTrue: [ myNext setPrev: myPrev ]. super destruct.! ! !SanitationEngineer methodsFor: 'private: accessing'! {SanitationEngineer INLINE} next ^ myNext! {void INLINE} setNext: n {SanitationEngineer} myNext := n! {void INLINE} setPrev: p {SanitationEngineer} myPrev := p! ! !SanitationEngineer methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! SanitationEngineer class instanceVariableNames: ''! (SanitationEngineer getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #EQ; yourself)! !SanitationEngineer class methodsFor: 'smalltalk: init'! linkTimeNonInherited FirstEngineer := NULL! ! !SanitationEngineer class methodsFor: 'sanitizing'! {void} garbageDay: required {BooleanVar} | se {SanitationEngineer} | se := FirstEngineer. [se ~~ NULL] whileTrue: [ se recycle: required. se := se next ]! !SanitationEngineer subclass: #Purgeror instanceVariableNames: ' myCount {IntegerVar} myPacker {DiskManager} myPurgePending {BooleanVar}' classVariableNames: 'PurgeRate {IntegerVar} ' poolDictionaries: '' category: 'Xanadu-Snarf'! Purgeror comment: 'We are about to garbage collect. Every so often, purge the objects that are clean so their flocks can be garbage collected.'! (Purgeror getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !Purgeror methodsFor: 'accessing'! {void INLINE} clearPurgePending myPurgePending := false. myCount := IntegerVar0! {BooleanVar INLINE} purgePending ^ myPurgePending! ! !Purgeror methodsFor: 'protected: creation'! create: packer {DiskManager} super create. myPacker _ packer. myCount _ IntegerVar0. myPurgePending _ false! ! !Purgeror methodsFor: 'invoking'! {void} recycle: required {BooleanVar} required ifTrue: [ myPurgePending := true. ^VOID]. (myCount >= PurgeRate and: [PurgeRate > IntegerVarZero]) ifTrue: [(InsideTransactionFlag fluidFetch or: [myPacker insideCommit]) ifFalse: [myPacker purgeClean. myCount _ IntegerVarZero. myPurgePending _ false] ifTrue: [myPurgePending _ true]] ifFalse: [myCount _ myCount + 1]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Purgeror class instanceVariableNames: ''! (Purgeror getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !Purgeror class methodsFor: 'smalltalk: init'! linkTimeNonInherited PurgeRate _ 40. [Abraham] USES! ! !Purgeror class methodsFor: 'creation'! make: packer {DiskManager} ^self create: packer! ! !Purgeror class methodsFor: 'setting'! {void} setPurgeRate: count {IntegerVar} PurgeRate _ count! !Heaper subclass: #Scrambler instanceVariableNames: '' classVariableNames: 'AllScramblers {MuTable of: Sequence and: Scrambler} ' poolDictionaries: '' category: 'Xanadu-lock'! Scrambler comment: 'A Scrambler implements a one-way hash function. It should be one-way, in that it should be difficult to unscramble, and it should be a hash, in that two similar inputs should produce very different outputs. It is furthermore desirable but not essential that the algorithm be cryptographically secure (the only way to unscramble an output is by scrambling all possible inputs and comparing), and one-to-one (two different inputs never produce the same output). Each subclass implements some particular algorithm such as Snefru, in response to the scrambling protocol. The system maintains a table of all of the known Scramblers, indexed by name (a PackOBits). At initialization time, each concrete subclass should use the DEFINE_SCRAMBLER("identifier",(scramblerExpression)) macro to place an instance in the table at some appropriate identifier. DEFINE_SCRAMBLER must be invoked inside an Initializer (e.g. in an initTimeNonInherited method). MatchLockSmiths store passwords in scrambled form, so that being able to read the LockSmith is not enough to find out the password. They also store the name of the Scrambler used to scramble it, so that trial passwords can be scrambled and compared.'! (Scrambler getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !Scrambler methodsFor: 'scrambling'! {UInt8Array} scramble: clear {UInt8Array} "Carry out a one-way hash function on the given clear text." self subclassResponsibility! ! !Scrambler methodsFor: 'tesing'! {UInt32} actualHashForEqual ^Heaper takeOop! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Scrambler class instanceVariableNames: ''! (Scrambler getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !Scrambler class methodsFor: 'was protected'! {void} remember: identifier {Sequence} with: scrambler {Scrambler} "Register the existence of a particular kind of scrambler. The identifier must be unique." AllScramblers at: identifier introduce: scrambler! ! !Scrambler class methodsFor: 'accessing'! {Scrambler} make: identifier {UInt8Array} "Return a scrambler with the given name. Fail with BLAST(NoSuchScrambler) if there is none." ScruTable problems.NotInTable handle: [ :boom | Heaper BLAST: #NoSuchScrambler] do: [^(AllScramblers get: (Sequence numbers: identifier)) cast: Scrambler]! ! !Scrambler class methodsFor: 'smalltalk: init'! initTimeNonInherited self REQUIRES: MuTable. self REQUIRES: SequenceSpace. AllScramblers := MuTable make: SequenceSpace make.! linkTimeNonInherited AllScramblers := NULL.! ! !Scrambler class methodsFor: 'smalltalk: macros'! {void} DEFINE.U.SCRAMBLER: identifier {String} with: scrambler {Scrambler} self REQUIRES: Scrambler. Scrambler remember: (Sequence string: identifier) with: scrambler! !Scrambler subclass: #NoScrambler instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-lock'! NoScrambler comment: 'Does not actually scramble anything.'! (NoScrambler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !NoScrambler methodsFor: 'scrambling'! {UInt8Array} scramble: clear {UInt8Array} ^clear! ! !NoScrambler methodsFor: 'testing'! {UInt32} actualHashForEqual ^#cat.U.NoScrambler hashForEqual + 1! {BooleanVar} isEqual: other {Heaper} ^other isKindOf: NoScrambler! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NoScrambler class instanceVariableNames: ''! (NoScrambler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !NoScrambler class methodsFor: 'smalltalk: init'! initTimeNonInherited Scrambler DEFINE.U.SCRAMBLER: 'NoScrambler' with: NoScrambler make! ! !NoScrambler class methodsFor: 'pseudo constructors'! {Scrambler} make ^self create! !Heaper subclass: #ScruSet instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Sets'! ScruSet comment: 'X++ has three basic kinds of collection classes. Tables, Sets and XuRegions. XuRegions are not-necessarily-discrete collections of positions, and are documented in the space module. Sets and Tables are both discrete and finite, and similar in many ways. Both originate in a three-way type distinction between: ScruX -- The protocol for examining one. I.e., it is *Scru*table ImmuX -- The contract guarantees that the set or table you''re looking at won''t change (though the things it contains may change) MuX -- Additional protocol for changing it. Concrete classes may be a subclass of any of the above. It makes sense to have a concrete subclass of ScruX which isn''t a subclass of either MuX or ImmuX when, for example, it represents a tracking, filtered view of some other set which is itself changing. All kinds of collection can be iterated over when appropriate using Steppers--our basic iteration abstraction (see Stepper). Immu''s are sort of like Stamps -- they represent a particular state a colection can have. Mu''s are sort of like Berts -- they represent a continuing collection identity which can change its current state. Sets are pure collections--their contents are just a set of Heapers. Sets (as opposed to tables) do not provide any organization of these contents.'! (ScruSet getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !ScruSet methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! {BooleanVar} contentsEqual: other {ScruSet} "Returns whether the two ScruSets have exactly the same set of elements at the moment. 'a->contentsEqual(b)' is equivalent to 'a->asImmuSet()->isEqual(b->asImmuSet())'." other count ~= self count ifTrue: [^false]. other stepper forEach: [ :each {Heaper} | (self hasMember: each) ifFalse: [^false]]. ^true! {UInt32} contentsHash "Has the same relationship to contentsEqual that hashForEqual has to isEqual. I.e., if 'a->contentsEqual (b)', then 'a->contentsHash() == b->contentsHash()'. The same complex caveats apply as to the stability and portability of the hash values as apply for hashForEqual." | result {UInt32} | result _ UInt32Zero. self stepper forEach: [ :each {Heaper} | result _ result bitXor: each hashForEqual]. ^result! {BooleanVar} hasMember: someone {Heaper} "Is someone a member of the set now?" self subclassResponsibility! {BooleanVar} intersects: other {ScruSet} "tell whether they have any points in common" "subclasses can override for efficiency" other isEmpty ifTrue: [ ^ false ]. self count > other count ifTrue: [^other intersects: self]. self stepper forEach: [:mem {Heaper} | (other hasMember: mem) ifTrue: [^true]]. ^false! {BooleanVar} isEmpty "Whether it currently has any elements" self subclassResponsibility! {BooleanVar} isEqual: other {Heaper} self subclassResponsibility! {BooleanVar} isSubsetOf: another {ScruSet} "Whether another currently has all my elements" self stepper forEach: [:elem {Heaper} | (another hasMember: elem) ifFalse: [^false]]. ^true! ! !ScruSet methodsFor: 'creation'! {ScruSet} copy "A new one whose initial state is my current state, but that doesn't track changes. Note that there is no implication that these can be 'destroy'ed separately, because (for example) an ImmuSet just returns itself" self subclassResponsibility! ! !ScruSet methodsFor: 'conversion'! {PtrArray} asArray "The elements in the set in an array, in some random order" | result {PtrArray} mine {Stepper} | self thingToDo. "make this faster" result := PtrArray nulls: self count DOTasLong. mine := self stepper. Int32Zero almostTo: result count do: [ :index {Int32} | result at: index store: mine fetch. mine step]. mine destroy. ^result! {ImmuSet} asImmuSet "Return an immu snapshot of my current state. Should probably be done with a Converter rather than with a message (for the reasons listed in the Converter class comment). In terms of the Stamp/Bert analogy mentioned in the class comment, asImmuSet is like asking for the current Stamp." self subclassResponsibility! {MuSet} asMuSet "Return a Mu whose initial state is the same as my current state, but which will now deviate independently of me. In terms of the Stamp/Bert analogy mentioned in the class comment, asMuSet is like asking for a new Bert starting on the current Stamp." self subclassResponsibility! ! !ScruSet methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name. self printOnWithSimpleSyntax: oo with: '{' with: ', ' with: '}'! {void} printOnWithSimpleSyntax: oo {ostream reference} with: open {char star} with: sep {char star} with: close {char star} self printOnWithSyntax: oo with: open with: sep with: close with: false! {void} printOnWithSyntax: oo {ostream reference} with: open {char star} with: sep {char star} with: close {char star} with: fullPrint {BooleanVar default: false} "For example, if we have the set '{a, b, c}' and we print it with 'p->printOnWithSyntax(oo, ""<<"", ""; "", "">>"");', we get '<>'. This is a convenient little hack for printing with all sorts of separators and brackets." | dSet {Stepper} elemCount {IntegerVar} printMore {BooleanVar} | printMore _ fullPrint not. elemCount _ IntegerVar0. oo << open. self isEmpty ifTrue: [oo << 'nullSet'] ifFalse: [dSet _ self stepper. [dSet hasValue and: [printMore]] whileTrue: [oo << dSet fetch. dSet step. dSet hasValue ifTrue: [oo << sep]. (printMore and: [(elemCount _ elemCount + 1) > 200]) ifTrue: [printMore _ false]]]. (printMore not and: [dSet hasValue]) ifTrue: [oo << 'etc...']. oo << close! ! !ScruSet methodsFor: 'enumerating'! {IntegerVar} count "How many elements are currently in the set. Being a set, if the same element is put into the set twice, it is only in the set once. 'Same' above is according to 'isEqual'." self subclassResponsibility! {Stepper} stepper "Returns a stepper which will enumerate all the elements of the set in some unspecified order" self subclassResponsibility! {Heaper} theOne "Iff I contain exactly one member, return it. Otherwise BLAST. The idea for this message is taken from the THE function of ONTIC (reference McAllester)" | stepper {Stepper} result {Heaper} | self count ~= 1 ifTrue: [ Heaper BLAST: #NotOneElement ]. stepper _ self stepper. result _ stepper fetch. stepper destroy. ^ result! ! !ScruSet methodsFor: 'private: smalltalk: private'! {void} inspect ^InspectorView open: (Sensor leftShiftDown ifTrue: [Inspector inspect: self] ifFalse: [SetInspector inspect: self])! ! !ScruSet methodsFor: 'smalltalk: conversion'! asOrderedCollection "return all of my elements in an ordered collection for smalltalk MVC hacking" | result {OrderedCollection} stomp {Stepper} | result _ OrderedCollection new: self count. stomp _ self stepper. [stomp hasValue] whileTrue: [result add: stomp get. stomp step]. ^result "| result {SortedCollection} stomp {Stepper} | result _ SortedCollection new: self count. stomp _ self stepper. [stomp hasValue] whileTrue: [result add: stomp get. stomp step]. ^result asOrderedCollection"! {void} do: aBlock {BlockClosure of: Heaper} self stepper forEach: aBlock! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ScruSet class instanceVariableNames: ''! (ScruSet getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !ScruSet class methodsFor: 'exceptions: exceptions'! problems.NotInSet ^self signals: #(NotInSet)! !ScruSet subclass: #ImmuSet instanceVariableNames: '' classVariableNames: 'EmptySet {ImmuSet wimpy} ' poolDictionaries: '' category: 'Xanadu-Collection-Sets'! ImmuSet comment: 'ImmuSets are ScruSets which are guaranteed never to change. ImmuSets correspond to the mathematical notion of a finite set of elements, except of course that here the elements can be any valid X++ object. Just like mathematical sets, two are equal (according to isEqual) iff they have the same elements. Just because the set cannot change, that doesn''t prevent any of the members from undergoing state change. ImmuSets implement some additional protocol to make new sets out of old ones according to the familiar set theoretic operators (like intersect). XuRegions are much like ImmuSets of Positions except that they aren''t necessarily finite or even enumerable. XuRegions implement a similar protocol, but aren''t polymorphic with ImmuSets. '! (ImmuSet getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !ImmuSet methodsFor: 'accessing'! {BooleanVar} hasMember: someone {Heaper} self subclassResponsibility! {BooleanVar} isEmpty self subclassResponsibility! ! !ImmuSet methodsFor: 'operations'! {ImmuSet} intersect: another {ScruSet} "Regular set intersection. Return an ImmuSet containing only those objects which are members of both sets" self subclassResponsibility! {ImmuSet} minus: another {ScruSet} "Return an ImmuSet containing those of my members which aren't members of 'another'" self subclassResponsibility! {ImmuSet} unionWith: another {ScruSet} "Return an ImmuSet containing those objects with are members of either of us" self subclassResponsibility! ! !ImmuSet methodsFor: 'adding-removing'! {ImmuSet} with: anElement {Heaper} "'set->with (anElement)' means the same as 'set->unionWith (immuSet (anElement))'. It returns an ImmuSet with all my members and having anElement as a member. If anElement is a member of me, then the result is identical to me." self subclassResponsibility! {ImmuSet} without: anElement {Heaper} "'set->without (anElement)' means the same as 'set->minus (immuSet (anElement))'. It returns an ImmuSet with all my members except anElement. If anElement isn't already a member, then the result is identical to me." self subclassResponsibility! ! !ImmuSet methodsFor: 'creation'! {ScruSet} copy "don't need to actually make a copy, as this is immutable" ^self! ! !ImmuSet methodsFor: 'conversion'! {ImmuSet} asImmuSet ^self! {MuSet} asMuSet self subclassResponsibility! ! !ImmuSet methodsFor: 'enumerating'! {IntegerVar} count self subclassResponsibility! {Stepper} stepper self subclassResponsibility! ! !ImmuSet methodsFor: 'testing'! {UInt32} actualHashForEqual ^self contentsHash! {BooleanVar} isEqual: other {Heaper} other cast: ImmuSet into: [:o | ^self contentsEqual: o] others: [^false]. ^ false "compiler fodder"! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ImmuSet class instanceVariableNames: ''! (ImmuSet getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !ImmuSet class methodsFor: 'smalltalk: constructors'! create.MuSet: ms ^ self new create.MuSet: ms! {ImmuSet} make: thing (thing isKindOf: XnRegion) ifTrue: [false assert: 'Use region convert: ImmuSet'. ^ImmuSet make.XuRegion: thing]. ^ImmuSet make.MuSet: (thing cast: MuSet)! ! !ImmuSet class methodsFor: 'protected: pseudo constructors'! {ImmuSet} from: set {MuSet} "This is for ImmuSet subclasses to produce results from temporary MuSets. The difference between this and ImmuSet make.MuSet: is that this doesn't make a copy of the MuSet when making an ImmuSetOnMu." set isEmpty ifTrue: [^ EmptySet]. set count == 1 ifTrue: [^ TinyImmuSet make: set theOne]. ^ ImmuSetOnMu make: set! ! !ImmuSet class methodsFor: 'pseudo constructors'! {ImmuSet INLINE} make ^EmptySet! {ImmuSet} make.MuSet: set {MuSet} set isEmpty ifTrue: [^ EmptySet]. set count == 1 ifTrue: [^ TinyImmuSet make: set theOne]. ^ ImmuSetOnMu make: (set copy cast: MuSet).! {ImmuSet} newWith: value {Heaper} "A single element ImmuSet" ^TinyImmuSet make: value! ! !ImmuSet class methodsFor: 'smalltalk: initialization'! initTimeNonInherited self REQUIRES: Stepper. EmptySet _ (EmptyImmuSet new.AllocType: #PERSISTENT) create.! linkTimeNonInherited EmptySet _ NULL! ! !ImmuSet class methodsFor: 'smalltalk: passe'! make.Heaper: aSingleton {Heaper} self passe. "use ImmuSet make with: aSingleton"! {ImmuSet} with: value {Heaper} "A single element ImmuSet" self passe. "use newWith:"! !ImmuSet subclass: #EmptyImmuSet instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Sets'! (EmptyImmuSet getOrMakeCxxClassDescription) attributes: ((Set new) add: #PSEUDO.COPY; add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !EmptyImmuSet methodsFor: 'enumerating'! {IntegerVar} count ^ IntegerVar0! {Stepper} stepper ^ Stepper emptyStepper! {Heaper} theOne Heaper BLAST: #NotOneElement. ^ NULL! ! !EmptyImmuSet methodsFor: 'adding-removing'! {ImmuSet} with: anElement {Heaper} ^TinyImmuSet make: anElement! {ImmuSet} without: anElement {Heaper unused} ^ self! ! !EmptyImmuSet methodsFor: 'accessing'! {BooleanVar} hasMember: someone {Heaper unused} ^ false! {BooleanVar} isEmpty ^ true! {BooleanVar} isSubsetOf: another {ScruSet unused} ^ true! ! !EmptyImmuSet methodsFor: 'operations'! {ImmuSet} intersect: another {ScruSet unused} ^ self! {ImmuSet} minus: another {ScruSet unused} ^ self! {ImmuSet} unionWith: another {ScruSet} ^ another asImmuSet! ! !EmptyImmuSet methodsFor: 'conversion'! {MuSet} asMuSet ^ MuSet make! ! !EmptyImmuSet methodsFor: 'unprotected for initer create'! create super create! ! !EmptyImmuSet methodsFor: 'creation'! {void} destroy "Don't destroy our single instance"! ! !EmptyImmuSet methodsFor: 'protected: destruct'! {void} destruct "This object is a canonical single instance, so its destructor should only be called after main has exited." 'if (!!Initializer::inStaticDestruction()) BLAST(SanityViolation);' translateOnly. super destruct! ! !EmptyImmuSet methodsFor: 'generated:'! {void} sendSelfTo: xmtr {Xmtr}! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! EmptyImmuSet class instanceVariableNames: ''! (EmptyImmuSet getOrMakeCxxClassDescription) attributes: ((Set new) add: #PSEUDO.COPY; add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !EmptyImmuSet class methodsFor: 'rcvr pseudo constructor'! {Heaper} make.Rcvr: rcvr {Rcvr} (rcvr cast: SpecialistRcvr) registerIbid: ImmuSet make. ^ImmuSet make! !ImmuSet subclass: #ImmuSetOnMu instanceVariableNames: 'setInternal {MuSet}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Sets'! (ImmuSetOnMu getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; add: #COPY; yourself)! !ImmuSetOnMu methodsFor: 'accessing'! {BooleanVar} hasMember: someone {Heaper} ^ setInternal hasMember: someone! {BooleanVar} isEmpty ^ setInternal isEmpty! {BooleanVar} isSubsetOf: another {ScruSet} ^ setInternal isSubsetOf: another! ! !ImmuSetOnMu methodsFor: 'enumerating'! {IntegerVar} count ^ setInternal count! {Stepper} stepper ^ setInternal stepper! {Heaper} theOne ^ setInternal theOne! ! !ImmuSetOnMu methodsFor: 'operations'! {ImmuSet} intersect: another {ScruSet} another isEmpty ifTrue: [ ^ ImmuSet make ] ifFalse: [| tmp {MuSet} | tmp _ (setInternal copy) quickCast: MuSet. tmp restrictTo: another. ^ ImmuSet from: tmp]! {ImmuSet} minus: another {ScruSet} another isEmpty ifTrue: [ ^ self ] ifFalse: [|tmp {MuSet} | tmp _ (setInternal copy) quickCast: MuSet. tmp wipeAll: another. ^ ImmuSet from: tmp]! {ImmuSet} unionWith: another {ScruSet} another isEmpty ifTrue: [ ^ self ] ifFalse: [| tmp {MuSet} | setInternal count < another count ifTrue: [^another asImmuSet unionWith: setInternal]. tmp _ setInternal copy quickCast: MuSet. tmp storeAll: another. ^ ImmuSet from: tmp]! ! !ImmuSetOnMu methodsFor: 'adding-removing'! {ImmuSet} with: anElement {Heaper} |tmp {MuSet} | tmp _ self asMuSet. tmp store: anElement. ^ ImmuSetOnMu create.MuSet: tmp! {ImmuSet} without: anElement {Heaper} |tmp {MuSet} | tmp _ (setInternal copy) quickCast: MuSet. tmp wipe: anElement. ^ ImmuSet from: tmp! ! !ImmuSetOnMu methodsFor: 'conversion'! {MuSet} asMuSet ^ (setInternal copy) cast: MuSet! ! !ImmuSetOnMu methodsFor: 'protected: create'! create.MuSet: fromSet {MuSet} "this set should be a copy for my own use" "the pseudo constructor enforces this" super create. setInternal _ fromSet! {void} destruct setInternal destroy. super destruct! ! !ImmuSetOnMu methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. setInternal _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: setInternal.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ImmuSetOnMu class instanceVariableNames: ''! (ImmuSetOnMu getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; add: #COPY; yourself)! !ImmuSetOnMu class methodsFor: 'creation'! {ImmuSet} make: aSet {MuSet} ^ self create.MuSet: aSet! !ImmuSet subclass: #TinyImmuSet instanceVariableNames: 'elementInternal {Heaper}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Sets'! TinyImmuSet comment: 'This is an efficient implementation of ImmuSets for zero and one element sets.'! (TinyImmuSet getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; add: #COPY; yourself)! !TinyImmuSet methodsFor: 'protected: creation'! create: only {Heaper} "Initialize a singleton immuset" super create. elementInternal _ only! ! !TinyImmuSet methodsFor: 'enumerating'! {IntegerVar} count ^ 1! {Stepper} stepper ^Stepper itemStepper: elementInternal! {Heaper} theOne ^ elementInternal! ! !TinyImmuSet methodsFor: 'adding-removing'! {ImmuSet} with: anElement {Heaper} (elementInternal isEqual: anElement) ifTrue: [^self] ifFalse: [| nuSet {MuSet} | nuSet _ MuSet make.Heaper: anElement. nuSet introduce: elementInternal. ^ImmuSet make: nuSet]! {ImmuSet} without: anElement {Heaper} (elementInternal isEqual: anElement) ifTrue: [^ ImmuSet make]. ^ self! ! !TinyImmuSet methodsFor: 'accessing'! {BooleanVar} hasMember: someone {Heaper} ^ elementInternal isEqual: someone! {BooleanVar} isEmpty ^ false! {BooleanVar} isSubsetOf: another {ScruSet} ^ another hasMember: elementInternal! ! !TinyImmuSet methodsFor: 'operations'! {ImmuSet} intersect: another {ScruSet} (another hasMember: elementInternal) ifTrue: [^ self] ifFalse: [^ ImmuSet make]! {ImmuSet} minus: another {ScruSet} (another hasMember: elementInternal) ifTrue: [^ ImmuSet make] ifFalse: [^ self]! {ImmuSet} unionWith: another {ScruSet} another isEmpty ifTrue: [^ self] ifFalse: [| nuSet {MuSet} | (another hasMember: elementInternal) ifTrue: [ ^ another asImmuSet ]. another count > 5 ifTrue: [^another asImmuSet unionWith: self]. nuSet _ MuSet make.Heaper: elementInternal. nuSet storeAll: another. ^ ImmuSet make: nuSet]! ! !TinyImmuSet methodsFor: 'conversion'! {MuSet} asMuSet ^ MuSet make.Heaper: elementInternal! ! !TinyImmuSet methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. elementInternal _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: elementInternal.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TinyImmuSet class instanceVariableNames: ''! (TinyImmuSet getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; add: #COPY; yourself)! !TinyImmuSet class methodsFor: 'create'! {ImmuSet} make: aHeaper {Heaper} ^ self create: aHeaper! !ScruSet subclass: #MuSet instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Sets'! MuSet comment: 'MuSets are a changable collection of elements. Added to the ScruSet protocol are messages for performing these changes. The "introduce/store/wipe/remove" suite is defined by analogy with similar methods in MuTable. See both ScruSet and MuTable.'! (MuSet getOrMakeCxxClassDescription) friends: '/* friends for class MuSet */ friend class ImmuSetOnMu; friend class COWMuSet;'; attributes: ((Set new) add: #DEFERRED; add: #EQ; yourself)! !MuSet methodsFor: 'accessing'! {BooleanVar} hasMember: someone {Heaper} self subclassResponsibility! {BooleanVar} isEmpty self subclassResponsibility! ! !MuSet methodsFor: 'operations'! {void} restrictTo: other {ScruSet} "Sort of intersect. Wipe from myself all elements that I don't have in common with other. Turn myself into the intersection of my current self and other." | tmp {MuSet} | tmp _ self copy cast: MuSet. tmp wipeAll: other. self wipeAll: tmp. tmp destroy.! {void} storeAll: other {ScruSet} "Sort of union. Store into myself all elements from other. Turn myself into the union of my current self and other." other stepper forEach: [:elem {Heaper wimpy} | self store: elem]! {void} wipeAll: other {ScruSet} "Sort of minus. Wipe from myself all elements from other. Turn myself into my current self minus other." other stepper forEach: [:elem {Heaper wimpy} | self wipe: elem]! ! !MuSet methodsFor: 'adding-removing'! {void} introduce: anElement {Heaper} "Add anElement to my members, but only if it isn't already a member. If it is already a member, BLAST" self subclassResponsibility! {void} remove: anElement {Heaper} "Remove anElement from my members. If it isn't currently a member, then BLAST" self subclassResponsibility! {void} store: anElement {Heaper} "Add anElement to my set of members. No semantic effect if anElement is already a member." self subclassResponsibility! {void} wipe: anElement {Heaper} "make anElement no longer be one of my members. No semantic effect if it already isn't a member." self subclassResponsibility! ! !MuSet methodsFor: 'creation'! {ScruSet} copy self subclassResponsibility! ! !MuSet methodsFor: 'conversion'! {ImmuSet} asImmuSet self isEmpty ifTrue: [^ ImmuSet make]. self count == 1 ifTrue: [^ ImmuSet make with: (self theOne)]. ^ ImmuSet make: self! {MuSet} asMuSet ^ self copy quickCast: MuSet! ! !MuSet methodsFor: 'enumerating'! {IntegerVar} count self subclassResponsibility! {Stepper} stepper self subclassResponsibility! ! !MuSet methodsFor: 'private: enumerating'! {Stepper} immuStepper self subclassResponsibility! ! !MuSet methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MuSet class instanceVariableNames: ''! (MuSet getOrMakeCxxClassDescription) friends: '/* friends for class MuSet */ friend class ImmuSetOnMu; friend class COWMuSet;'; attributes: ((Set new) add: #DEFERRED; add: #EQ; yourself)! !MuSet class methodsFor: 'smalltalk: passe'! make.Region: region {XnRegion} "someSize is a non-semantic hint about how big the set might get." | result {MuSet} | self passe. result _ ActualHashSet make.IntegerVar: region count. region stepper forEach: [:position {Position} | result store: position]. ^result! ! !MuSet class methodsFor: 'pseudo constructors'! {MuSet} fromStepper: stepper {Stepper} | result {MuSet} | result _ MuSet make. stepper forEach: [ :element {Heaper} | result store: element]. ^result! {MuSet} make ^ActualHashSet make! {MuSet} make.Heaper: item {Heaper} ^ActualHashSet make.Heaper: item! {MuSet} make.IntegerVar: someSize {IntegerVar} "someSize is a non-semantic hint about how big the set might get." ^ActualHashSet make.IntegerVar: someSize! ! !MuSet class methodsFor: 'smalltalk: defaults'! make: something (something isKindOf: Integer) ifTrue: [^self make.IntegerVar: something]. ^self make.Region: (something cast: XnRegion)! ! !MuSet class methodsFor: 'smalltalk: initialization'! initTimeNonInherited self REQUIRES: ActualHashSet! ! !MuSet class methodsFor: 'exceptions: exceptions'! problems.AlreadyInSet ^self signals: #(AlreadyInSet)! !MuSet subclass: #GrandHashSet instanceVariableNames: ' grandNodes {PtrArray copy of: GrandNode} numNodes {Int32 copy} nodeIndexShift {Int32 copy} myTally {Counter copy} myDoublingFrontIndex {Counter copy} myDoublingPasses {Counter copy} cacheHash {UInt32 NOCOPY} cacheValue {Heaper wimpy NOCOPY} myOutstandingSteppers {IntegerVar NOCOPY}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Grand'! (GrandHashSet getOrMakeCxxClassDescription) friends: '/* friends for class GrandHashSet */ friend SPTR(GrandHashSet) grandHashSet (); friend SPTR(GrandHashSet) grandHashSet (Int4 nNodes); friend class GrandHashSetStepper; '; attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !GrandHashSet methodsFor: 'adding-removing'! {void} introduce: aHeaper {Heaper} | hash {UInt32} node {GrandNode} | self checkSteppers. aHeaper == NULL ifTrue: [Heaper BLAST: #NullInsertion]. hash _ ExponentialHashMap exponentialMap: aHeaper hashForEqual. node _ (grandNodes fetch: hash // nodeIndexShift) cast: GrandNode. (node fetch: aHeaper with: hash) ~~ NULL ifTrue: [Heaper BLAST: #AlreadyInSet] ifFalse: [| newEntry {GrandEntry} | DiskManager consistent: 6 with: [newEntry _ GrandSetEntry make: aHeaper with: hash. node store.Entry: newEntry]]. myTally increment. self considerNeedForDoubling. self invalidateCache.! {void} remove: aHeaper {Heaper} ((self hasMember: aHeaper) == NULL) ifTrue: [Heaper BLAST: #NotInSet] ifFalse: [self wipe: aHeaper]! {void} store: aHeaper {Heaper} | hash {UInt32} node {GrandNode} newEntry {GrandEntry} test {BooleanVar} | self checkSteppers. aHeaper == NULL ifTrue: [Heaper BLAST: #NullInsertion]. hash _ ExponentialHashMap exponentialMap: aHeaper hashForEqual. node _ (grandNodes fetch: hash // nodeIndexShift) cast: GrandNode. test _ (node fetch: aHeaper with: hash) == NULL. DiskManager consistent: 6 with: [newEntry _ GrandSetEntry make: aHeaper with: hash. node store.Entry: newEntry]. test ifTrue: [myTally increment. self considerNeedForDoubling]. self invalidateCache.! {void} wipe: aHeaper {Heaper} | hash {UInt32} node {GrandNode} | self checkSteppers. hash _ ExponentialHashMap exponentialMap: aHeaper hashForEqual. node _ (grandNodes fetch: hash // nodeIndexShift) cast: GrandNode. (node fetch: aHeaper with: hash) ~~ NULL ifTrue: [node wipe: aHeaper with: hash. myTally decrement]! ! !GrandHashSet methodsFor: 'accessing'! {IntegerVar} count ^myTally count! {BooleanVar} hasMember: aHeaper {Heaper} | hash {UInt32} result {Heaper} | hash _ ExponentialHashMap exponentialMap: aHeaper hashForEqual. "(cacheKey ~~ NULL and: [cacheHash == hash and: [cacheKey isEqual: key]]) ifTrue: [ ^ cacheValue ]." result _ ((grandNodes fetch: hash // nodeIndexShift) cast: GrandNode) fetch: aHeaper with: hash. "result ~~ NULL ifTrue: [cacheHash _ hash. cacheKey _ key. cacheValue _ result]." ^ result ~~ NULL! ! !GrandHashSet methodsFor: 'testing'! {BooleanVar} isEmpty ^myTally count == IntegerVar0! ! !GrandHashSet methodsFor: 'conversion'! {ImmuSet} asImmuSet self willNotImplement. ^ NULL! {MuSet} asMuSet self willNotImplement. ^ NULL! ! !GrandHashSet methodsFor: 'creation'! {ScruSet} copy | newSet {MuSet} | newSet _ GrandHashSet make: numNodes. self stepper forEach: [:e {Heaper} | newSet store: e]. ^ newSet! ! !GrandHashSet methodsFor: 'printing'! {void} printOn: aStream {ostream reference} aStream << 'GrandHashSet(' << self count << ' entries over ' << numNodes << ' nodes)'! {void} printOnWithSimpleSyntax: oo {ostream reference} with: open {char star} with: sep {char star} with: close {char star} | stomp {Stepper} | oo << open. self isEmpty ifTrue: [oo << 'empty'] ifFalse: [stomp _ self stepper. [stomp hasValue] whileTrue: [oo << stomp fetch. stomp step. stomp hasValue ifTrue: [oo << sep]]. stomp destroy]. oo << close! ! !GrandHashSet methodsFor: 'enumerating'! {Stepper} stepper ^ GrandHashSetStepper create: self! ! !GrandHashSet methodsFor: 'protected: creation'! create: nNodes {Int32} | aNode {GrandNode} | super create. numNodes _ nNodes. nodeIndexShift _ ExponentialHashMap hashBits // numNodes. grandNodes _ PtrArray nulls: numNodes. DiskManager consistent: 2 * numNodes + 3 with: [Int32Zero almostTo: numNodes do: [:i {Int32} | aNode _ GrandNode make. grandNodes at: i store: aNode]. myTally _ Counter make. myDoublingFrontIndex _ Counter make. myDoublingPasses _ Counter make]. myOutstandingSteppers _ IntegerVarZero. self invalidateCache! {void} destruct | temp {Heaper} | self checkSteppers. DiskManager consistent: numNodes with: [UInt32Zero almostTo: numNodes do: [:i {UInt32} | (temp _ grandNodes fetch: i) ~~ NULL ifTrue: [temp destroy]]]. super destruct! ! !GrandHashSet methodsFor: 'private: housekeeping'! {void} considerNeedForDoubling "Compute location of doubling front from tally. If front crosses a node boundary" " and that node has index higher than doublingFrontIndex then double that node." " Then increase doublingFrontIndex. If the front has hit the end of the table index" " reset it to zero. This allows elements to be wiped from the table without causing" " extra node doubling to occur on later insertions. This aims for 80% max table" "loading using an approximation of the formula given in the Fagin paper." | desiredDoublingIndex {Int32} x {IEEEDoubleVar} dfi {Int32} | x _ 0.05"Magic number" * numNodes * (1 bitShift: myDoublingPasses count DOTasLong) * GrandNode primaryPageSize. desiredDoublingIndex _ (myTally count DOTasLong asFloat / x) asInteger "- 1". dfi _ myDoublingFrontIndex count DOTasLong. desiredDoublingIndex >= (dfi + 1) ifTrue: [(grandNodes fetch: dfi) ~~ NULL ifTrue: [(GrandNodeDoubler make: ((grandNodes fetch: dfi) cast: GrandNode)) schedule]. dfi _ myDoublingFrontIndex increment DOTasLong]. dfi >= numNodes ifTrue: [myDoublingFrontIndex setCount: IntegerVar0. myDoublingPasses increment]! {void} invalidateCache cacheValue _ NULL.! ! !GrandHashSet methodsFor: 'receiver'! {void RECEIVE.HOOK} restartGrandHashSet: trans {Rcvr unused default: NULL} "re-initialize the non-persistent part" cacheValue _ NULL. myOutstandingSteppers _ IntegerVar0! ! !GrandHashSet methodsFor: 'private: friendly'! {GrandNode} nodeAt: idx {IntegerVar} ^ (grandNodes fetch: idx DOTasLong) cast: GrandNode! {IntegerVar} nodeCount ^ numNodes! ! !GrandHashSet methodsFor: 'private: smalltalk: private'! inspectPieces ^grandNodes asOrderedCollection! ! !GrandHashSet methodsFor: 'private: enumerating'! {void INLINE} checkSteppers myOutstandingSteppers > IntegerVar0 ifTrue: [ Heaper BLAST: #ModifyBlockedByOutstandingStepper ]! {void} fewerSteppers myOutstandingSteppers _ myOutstandingSteppers - 1. myOutstandingSteppers < IntegerVar0 ifTrue: [ Heaper BLAST: #TooManySteppersReleased ]! {Stepper} immuStepper self hack. "This will have to be fixed if GrandHashSet::stepper ever makes a copy" ^ self stepper! {void} moreSteppers myOutstandingSteppers _ myOutstandingSteppers + 1! ! !GrandHashSet methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. grandNodes _ receiver receiveHeaper. numNodes _ receiver receiveInt32. nodeIndexShift _ receiver receiveInt32. myTally _ receiver receiveHeaper. myDoublingFrontIndex _ receiver receiveHeaper. myDoublingPasses _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: grandNodes. xmtr sendInt32: numNodes. xmtr sendInt32: nodeIndexShift. xmtr sendHeaper: myTally. xmtr sendHeaper: myDoublingFrontIndex. xmtr sendHeaper: myDoublingPasses.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GrandHashSet class instanceVariableNames: ''! (GrandHashSet getOrMakeCxxClassDescription) friends: '/* friends for class GrandHashSet */ friend SPTR(GrandHashSet) grandHashSet (); friend SPTR(GrandHashSet) grandHashSet (Int4 nNodes); friend class GrandHashSetStepper; '; attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !GrandHashSet class methodsFor: 'pseudoConstructors'! make ^ self create: 32 "A Very big table"! make: nNodes {Int32} ^ self create: nNodes! ! !GrandHashSet class methodsFor: 'smalltalk: initialization'! initTimeNonInherited "GrandHashTable initTimeNonInherited" self REQUIRES: ExponentialHashMap! !MuSet subclass: #HashSet instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Sets'! HashSet comment: ' The HashSet class is an implementation of a MuTable set that can contain arbitrary Heapers. It uses the hashForEqual member function to get a hash value for the items contained in the set. The set establishes the equality of objects in the set through the isEqual: function. The implemention of HashSet is straightforward. There are primitive tables used to store pointers to the stored items (myHashEntries), and their corresponding hash values (myHashValues). The HashSet also maintain a current tally of the number of items in the set. definition: preferred location - the location calculated from item hashForEqual mod tableSize. The search routine first calculates the preferred location. This is used as the first location in the myHashEntries table to test for the presence of the item, and the search proceeds forward (in a linear probe) from there. If there is no object at that position, the routine assumes the item is not in the table. If there is an item there, the first test is to check if the item''s hash matches the hash myHashValues at that position. If the match is successful, a full isEqual: test is performed. If the isEqual: test succeeds, the item is present in the set. If either test fails, the entry at the desired location is tested to see if it is closer to its own preferred location than the item (a test which necessarily fails the first time). If it is closer, the item is not in the set. (This extra test is what distinguishes an ordered hash set from an ordinary hash set. It often detects the absense of an item well before an empty slot is encountered, and the advantage becomes pronounced as the set fills up. Ordered hash sets with linear probe beat ordinary hash sets with secondary clustering on misses (the big time eater), yet they preserve linear probe''s easy deletion.) On insertion to the set, the hash and probe sequence is essentially the same as the search. The main exception is that on a hash collision, the item bumps down any item that is no farther than its own preferred position. An example is perhaps in order: the set contains items a, b, and c in table locations 3, 4, and 5. Assume that a has location 2 as its preferred location, while b and c both have location 4 as their preferred location. Now, if we attempt to add an item d to the table, and item d were to have a preferred location of 3. Since 3 is already occupied by something that is already far from its preferred location, we probe for a another location. At location 4, item d is displaced by one from its preferred location. Since b is in it''s preferred location (4) d replaces it, and we move item b down. Item c is in location 5 because it had already been bumped from location 4 when b was inserted previously. B again ties with c, so it pushes it out of location 5, replacing it there. Item c will end up in location 6. This probe function minimizes the individual displacement of hash misses, while keeping the most items in their preferred locations. Note that, though the choice of which item to bump is obvious when the distances from home are different, when they are equal we could have given preference to either the new or the old item. We chose to put the new item closer to its preferred location, on the assumption that things entered recently are more likely to be looked up than things entered long ago. This algorithm was derived from a short discussion with Michael McClary (probably completely missing his intended design - all mistakes are mine -- heh). (Unfortunately, I wasn''t clear in the discussion. Since hugh was unavailable when I discovered this, I''ve taken the opportunity to practice with Smalltalk and corrected both the explanation and the code rather than sending him a clarification. -- michael)'! (HashSet getOrMakeCxxClassDescription) friends: '/* friends for class HashSet */ friend class HashSetTester;'; attributes: ((Set new) add: #DEFERRED; yourself)! !HashSet methodsFor: 'accessing'! {BooleanVar} hasMember: someone {Heaper} self subclassResponsibility! {BooleanVar} isEmpty self subclassResponsibility! ! !HashSet methodsFor: 'creation'! {ScruSet} copy self subclassResponsibility! ! !HashSet methodsFor: 'enumerating'! {IntegerVar} count self subclassResponsibility! {Stepper} stepper self subclassResponsibility! {Heaper} theOne self subclassResponsibility! ! !HashSet methodsFor: 'adding-removing'! {void} introduce: anElement {Heaper} self subclassResponsibility! {void} remove: anElement {Heaper} self subclassResponsibility! {void} store: anElement {Heaper} "Add anElement to my set of members. No semantic effect if anElement is already a member." self subclassResponsibility! {void} wipe: anElement {Heaper} "make anElement no longer be one of my members. No semantic effect if it already isn't a member." self subclassResponsibility! ! !HashSet methodsFor: 'conversion'! {ImmuSet} asImmuSet self isEmpty ifTrue: [^ ImmuSet make]. self count == 1 ifTrue: [^ ImmuSet make with: (self theOne)]. ^ ImmuSet make: self! {MuSet} asMuSet ^ self copy quickCast: MuSet! ! !HashSet methodsFor: 'private: testing access'! {void} printInternals: oo {ostream reference} self subclassResponsibility! ! !HashSet methodsFor: 'private: enumerating'! {Stepper} immuStepper self unimplemented. ^NULL! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HashSet class instanceVariableNames: ''! (HashSet getOrMakeCxxClassDescription) friends: '/* friends for class HashSet */ friend class HashSetTester;'; attributes: ((Set new) add: #DEFERRED; yourself)! !HashSet class methodsFor: 'pseudo constructors'! make ^ActualHashSet make! make.Heaper: something {Heaper} | set {ActualHashSet} | set _ ActualHashSet make.IntegerVar: 1. set store: something. ^ set! make.IntegerVar: someSize {IntegerVar} ^ ActualHashSet make.IntegerVar: someSize.! !HashSet subclass: #ActualHashSet instanceVariableNames: ' myHashValues {UInt32Array NOCOPY} myHashEntries {SharedPtrArray NOCOPY} myTally {Int32}' classVariableNames: ' AddOver {IntegerVar smalltalk} AddTallys {Array smalltalk} DeleteOver {IntegerVar smalltalk} DeleteTallys {Array smalltalk} NewSetCount {IntegerVar smalltalk} SetKillCount {IntegerVar smalltalk} StepperCount {IntegerVar smalltalk} StepperOver {IntegerVar smalltalk} StepperTally {Array smalltalk} TestOver {IntegerVar smalltalk} TestTallys {Array smalltalk} ' poolDictionaries: '' category: 'Xanadu-Collection-Sets'! (ActualHashSet getOrMakeCxxClassDescription) friends: '/* friends for class ActualHashSet */ friend class HashSetTester;'; attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !ActualHashSet methodsFor: 'testing'! {UInt32} contentsHash | hashResult {UInt32} | hashResult _ UInt32Zero. UInt32Zero almostTo: myHashEntries count do: [:idx {UInt32} | (myHashEntries fetch: idx) ~~ NULL ifTrue: [hashResult _ hashResult + (myHashValues uIntAt: idx)]]. ^hashResult! ! !ActualHashSet methodsFor: 'accessing'! {IntegerVar} count ^ myTally! {BooleanVar} hasMember: someone {Heaper} [self class countTest: myTally] smalltalkOnly. ^(self hashFind: someone) >= Int32Zero! {BooleanVar} isEmpty ^ myTally == UInt32Zero! ! !ActualHashSet methodsFor: 'creation'! {ScruSet} copy ^ActualHashSet create: myTally with: myHashValues with: myHashEntries! ! !ActualHashSet methodsFor: 'protected: creation'! create: newTally {Int32} with: entries {SharedPtrArray} super create. myTally _ newTally. myHashValues _ UInt32Array make: entries count. myHashEntries _ entries. myHashEntries shareMore. [NewSetCount _ NewSetCount + 1] smalltalkOnly.! create: newTally {Int32} with: hashValues {UInt32Array} with: entries {SharedPtrArray} super create. myTally _ newTally. myHashValues _ hashValues. myHashEntries _ entries. myHashEntries shareMore. [NewSetCount _ NewSetCount + 1] smalltalkOnly.! {void} destruct myHashEntries shareLess. super destruct! ! !ActualHashSet methodsFor: 'enumerating'! {Stepper} stepper [StepperCount _ StepperCount + 1. self class countStepper: myTally] smalltalkOnly. ^ HashSetStepper make: myHashEntries! {Heaper} theOne myTally ~~ 1 ifTrue: [Heaper BLAST: #NotOneElement]. Int32Zero almostTo: myHashEntries count do: [:i {Int32} | (myHashEntries fetch: i) ~~ NULL ifTrue: [^myHashEntries fetch: i]]. ^NULL! ! !ActualHashSet methodsFor: 'operations'! {void} storeAll: other {ScruSet} "union equivalent" | haveStored {BooleanVar} | haveStored _ false. other stepper forEach: [:elem {Heaper wimpy} | (self hashFind: elem) < Int32Zero ifTrue: [haveStored ifFalse: [haveStored _ true. [self class countAdd: myTally] smalltalkOnly. self checkSize: other count DOTasLong]. self hashStore: elem with: myHashValues with: myHashEntries. myTally _ myTally + 1]].! {void} wipeAll: other {ScruSet} "Sort of minus. Wipe from myself all elements from other. Turn myself into my current self minus other." "Maintainance note: this duplicates some code in wipe: for efficiency" | loc {Int32} haveWritten {BooleanVar} | myTally = UInt32Zero ifTrue: [^ VOID]. haveWritten _ false. other stepper forEach: [:elem {Heaper wimpy} | (loc _ self hashFind: elem) >= Int32Zero ifTrue: [haveWritten ifFalse: [self aboutToWrite. haveWritten _ true. [self class countDelete: myTally] smalltalkOnly.]. self hashRemove: (loc basicCast: UInt32). myTally _ myTally - 1]]! ! !ActualHashSet methodsFor: 'adding-removing'! {void} introduce: anElement {Heaper} [self class countAdd: myTally] smalltalkOnly. self checkSize: 1. (self hashFind: anElement) >= Int32Zero ifTrue: [Heaper BLAST: #AlreadyInSet] ifFalse: [self hashStore: anElement with: (myHashValues basicCast: UInt32Array) with: (myHashEntries basicCast: PtrArray). myTally _ myTally + 1]! {void} remove: anElement {Heaper} | loc {Int32} | [self class countDelete: myTally] smalltalkOnly. self aboutToWrite. (loc _ self hashFind: anElement) >= Int32Zero ifTrue: [self hashRemove: (loc basicCast: UInt32). myTally _ myTally - 1] ifFalse: [Heaper BLAST: #NotInSet]! {void} store: anElement {Heaper} "maintainance note: storeAll: has a copy of the code starting at self hashFind:... for efficiency." (self hashFind: anElement) < Int32Zero ifTrue: [self checkSize: 1. self hashStore: anElement with: (myHashValues basicCast: UInt32Array) with: (myHashEntries basicCast: PtrArray). [self class countAdd: myTally] smalltalkOnly. myTally _ myTally + 1]! {void} wipe: anElement {Heaper} | loc {Int32} | myTally = UInt32Zero ifTrue: [^ VOID]. (loc _ self hashFind: anElement) >= Int32Zero ifTrue: [[self class countDelete: myTally] smalltalkOnly. self aboutToWrite. self hashRemove: (loc basicCast: UInt32). myTally _ myTally - 1]! ! !ActualHashSet methodsFor: 'private: housekeeping'! {void INLINE} aboutToWrite "If my contents are shared, and I'm about to change them, make a copy of them." myHashEntries shareCount > 1 ifTrue: [self actualAboutToWrite]! {void} actualAboutToWrite | newValues {UInt32Array} newEntries {SharedPtrArray} | newValues _ myHashValues copy cast: UInt32Array. newEntries _ myHashEntries copy cast: SharedPtrArray. myHashEntries shareLess. myHashValues _ newValues. myHashEntries _ newEntries. myHashEntries shareMore! {void} checkSize: byAmount {Int32} | newSize {Int32} newValues {UInt32Array} newEntries {SharedPtrArray} he {Heaper wimpy} | "Leave a third of free space." (((myTally + byAmount) * 5) bitShiftRight: 2) < myHashEntries count ifTrue: [self aboutToWrite. ^VOID]. newSize _ LPPrimeSizeProvider make uInt32PrimeAfter: ((myHashValues count * 2) + byAmount). newValues _ UInt32Array make: newSize. newEntries _ SharedPtrArray make: newSize. Int32Zero almostTo: myHashValues count do: [:from {Int32 register} | (he _ myHashEntries fetch: from) ~~ NULL ifTrue: [self hashStore: he with: newValues with: newEntries]]. myHashEntries shareCount > 1 ifTrue: [myHashEntries shareLess] ifFalse: [myHashValues destroy. myHashEntries destroy]. myHashValues _ newValues. myHashEntries _ newEntries. myHashEntries shareMore! {Int32} distanceFromHome: loc {UInt32} with: home {UInt32} with: modulus {UInt32} | dist {Int32} | [^ (loc - home) \\ modulus] smalltalkOnly. "alternate coding if modulus doesn't handle negatives the same as smalltalk (positive remainder only)" [dist _ (loc - home). dist < Int32Zero ifTrue: [dist _ dist + modulus]. ^ dist] translateOnly! ! !ActualHashSet methodsFor: 'private: hash resolution'! {Int32} hashFind: item {Heaper} "Starting at the item's preferred location and iterating (not recurring!!) around the set's storage while the slots we're examining are occupied... If the current slot's occupant is the target item, return a hit if the current occupant is closer to it's preferred location, return a miss. If we've gone all the way around, return a miss." | tSize {UInt32} current {UInt32} currentValue {UInt32} currentEntry {Heaper} currentHome {UInt32} targetValue {UInt32} targetHome {UInt32} | tSize _ myHashValues count. targetValue _ item hashForEqual. targetHome _ current _ targetValue \\ tSize. [(currentEntry _ myHashEntries fetch: current) ~~ NULL] whileTrue: [ currentValue _ myHashValues uIntAt: current. currentValue = targetValue ifTrue: [(currentEntry isEqual: item) ifTrue: [^current]]. "Found it." currentHome _ currentValue \\ tSize. (self distanceFromHome: current with: targetHome with: tSize) > (self distanceFromHome: current with: currentHome with: tSize) ifTrue: [^ -1]. "Would have seen it by now." current _ current + 1 \\ tSize. current = targetHome ifTrue: [^ -1]. "All the way around." ]. ^ -1 "Found an empty slot."! {void} hashRemove: from {UInt32} "Remove the indicated item from the set. Iteratively (not recursively!!) move other items up until one is NULL or happier where it is." | tSize {UInt32} current {UInt32} next {UInt32} nextValue {UInt32} nextEntry {Heaper} | current _ from. tSize _ myHashValues count. [(nextEntry _ myHashEntries fetch: (next _ current + 1 \\ tSize)) ~~ NULL and: [((nextValue _ myHashValues uIntAt: next) \\ tSize) ~= next]] whileTrue: [ myHashEntries at: current store: nextEntry. myHashValues at: current storeUInt: nextValue. current _ next. ]. myHashEntries at: current store: NULL. myHashValues at: current storeUInt: UInt32Zero.! {void} hashStore: item {Heaper} with: values {UInt32Array} with: entries {PtrArray} "Starting at the new item's preferred location and iterating (not recurring!!) around the set's storage while the slots we're examining are occupied. (Caller assures us there IS a vacant slot) if the current occupant is no closer to it's preferred location, exchange it with the 'new' one. Bail out if the current occupant IS the new one. Store the currently 'new' item." | tSize {UInt32} current {UInt32} itemValue {UInt32} movingValue {UInt32} movingEntry {Heaper} movingEntrysHome {UInt32} sittingValue {UInt32} sittingEntry {Heaper} sittingEntrysHome {UInt32} | tSize _ values count. movingEntry _ item. movingValue _ itemValue _ movingEntry hashForEqual. movingEntrysHome _ current _ movingValue \\ tSize. [(sittingEntry _ entries fetch: current) ~~ NULL] whileTrue: [ sittingValue _ values uIntAt: current. sittingEntrysHome _ sittingValue \\ tSize. "If the test below is >, new items are stored as far as possible from their desired location, giving the better slots to previous entries. If it is >=, new items are stored as close as possible to their desired locations, with older items moved farther down, giving the better slots to the more recent items. (Changing this test to > requires moving the duplicate item test.)" (self distanceFromHome: current with: movingEntrysHome with: tSize) >= (self distanceFromHome: current with: sittingEntrysHome with: tSize) ifTrue: [ "Bump the old occupant to another slot." entries at: current store: movingEntry. values at: current storeUInt: movingValue. movingEntry _ sittingEntry. movingValue _ sittingValue. movingEntrysHome _ sittingEntrysHome. "If we just picked up the same thing we were originally trying to add, we were trying to insert a duplicate. We may have reordered the collision set, or we may have just swapped the item with itself, but either way we're done. (Perhaps we should return an indication that the duplicate was found????)" ((movingValue = itemValue) and: [movingEntry isEqual: item]) ifTrue: [^ VOID ]. "item already in set, return." ]. current _ current + 1 \\ tSize. ]. entries at: current store: movingEntry. "Empty slot found. Drop the new entry into it." values at: current storeUInt: movingValue.! ! !ActualHashSet methodsFor: 'private: testing access'! {UInt32} entryTableSize ^ myHashEntries count! {void} printInternals: oo {ostream reference} "This method is for regression testing." | tSize {UInt32} tValue {UInt32} | tSize _ myHashValues count. oo << 'tally == ' << myTally << ' '. UInt32Zero almostTo: myHashEntries count do: [:idx {UInt32} | oo << idx << ': (' << ((tValue _ myHashValues uIntAt: idx) \\ tSize). oo << ', ' << (self distanceFromHome: idx with: tValue with: tSize) << ') '. [ tValue printOn: oo base: 16.] smalltalkOnly. '{ char buffer[9]; sprintf(buffer, "%X", tValue); oo << buffer; }' translateOnly. oo << ', ' << (myHashEntries fetch: idx) << ' ']. oo << ' '! ! !ActualHashSet methodsFor: 'hooks:'! {void RECEIVE.HOOK} receiveHashSet: rcvr {Rcvr} "Make myHashEntries large enough that we won't grow." | count {Int32} | count _ LPPrimeSizeProvider make uInt32PrimeAfter: (myTally * 2). myHashEntries _ SharedPtrArray make: count. myHashEntries shareMore. myHashValues _ UInt32Array make: count. myTally timesRepeat: [self hashStore: rcvr receiveHeaper with: myHashValues with: myHashEntries]! {void SEND.HOOK} sendHashSet: xmtr {Xmtr} "This currently doesn't take advantage of the optimizations in TableEntries. It should." | count {Int32} | count _ Int32Zero. self stepper forEach: [:value {Heaper} | xmtr sendHeaper: value. count _ count + 1]. count == myTally assert: 'Must write every element'.! ! !ActualHashSet methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myTally _ receiver receiveInt32. self receiveHashSet: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendInt32: myTally. self sendHashSet: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ActualHashSet class instanceVariableNames: ''! (ActualHashSet getOrMakeCxxClassDescription) friends: '/* friends for class ActualHashSet */ friend class HashSetTester;'; attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !ActualHashSet class methodsFor: 'smalltalk: initialization'! cleanupGarbage [AddTallys _ nil. DeleteTallys _ nil. TestTallys _ nil. StepperTally _ nil] smalltalkOnly.! initTimeNonInherited self REQUIRES: LPPrimeSizeProvider. "((5 - 10) + 17) == ((5 - 10) \\ 17) assert: 'incorrect modulus - change HashSet distanceFromHome'"! linkTimeNonInherited [AddTallys _ Array new: 500 withAll: 0. DeleteTallys _ Array new: 500 withAll: 0. TestTallys _ Array new: 500 withAll: 0. StepperTally _ Array new: 500 withAll: 0. AddOver _ DeleteOver _ TestOver _ StepperOver _ 0. StepperCount _ NewSetCount _ SetKillCount _ 0.] smalltalkOnly! ! !ActualHashSet class methodsFor: 'pseudo constructors'! make ^ActualHashSet create: Int32Zero with: (SharedPtrArray make: 7)! make.Heaper: something {Heaper} | set {ActualHashSet} | set _ ActualHashSet make.IntegerVar: 1. set store: something. ^ set! make.IntegerVar: someSize {IntegerVar} ^ActualHashSet create: Int32Zero with: (SharedPtrArray make: (LPPrimeSizeProvider make uInt32PrimeAfter: someSize DOTasLong))! ! !ActualHashSet class methodsFor: 'smalltalk: instrumentation'! {String} arrayStats: array {Array} | oo minIdx maxIdx idx medCnt mode modeVal totCnt avg | oo _ '' asText writeStream. minIdx _ 0. maxIdx _ 0. idx _ 1. [minIdx = 0 and: [idx < array size]] whileTrue: [ (array at: idx) > 0 ifTrue: [minIdx _ idx] ifFalse: [idx _ idx + 1]]. idx _ array size. [maxIdx = 0 and: [idx > 0]] whileTrue: [ (array at: idx) > 0 ifTrue: [maxIdx _ idx] ifFalse: [idx _ idx - 1]]. medCnt _ 0. mode _ 0. modeVal _ 0. minIdx to: maxIdx do: [:i | | cv | cv _ array at: i. medCnt _ medCnt + (cv * i). totCnt _ totCnt + cv. cv > modeVal ifTrue: [mode _ i. modeVal _ cv]]. avg _ totCnt / (maxIdx - minIdx).! {void} countAdd: tally {IntegerVar} tally < AddTallys size ifTrue: [AddTallys at: tally+1 put: ((AddTallys at: tally+1) + 1)] ifFalse: [AddOver _ AddOver + 1]! {void} countDelete: tally {IntegerVar} tally < DeleteTallys size ifTrue: [DeleteTallys at: tally+1 put: ((DeleteTallys at: tally+1) + 1)] ifFalse: [DeleteOver _ DeleteOver + 1]! {void} countStepper: tally {IntegerVar} tally < StepperTally size ifTrue: [StepperTally at: tally+1 put: ((StepperTally at: tally+1) + 1)] ifFalse: [StepperOver _ StepperOver + 1]! {void} countTest: tally {IntegerVar} tally < TestTallys size ifTrue: [TestTallys at: tally+1 put: ((TestTallys at: tally+1) + 1)] ifFalse: [TestOver _ TestOver + 1]! !Heaper subclass: #ScruTable instanceVariableNames: '' classVariableNames: ' NotInTableSignal {Signal smalltalk} WrongCoordSpaceSignal {Signal smalltalk} ' poolDictionaries: '' category: 'Xanadu-Collection-Tables'! ScruTable comment: 'Please read class comment for ScruSet first. Like Sets, Tables represent collections of Heapers, and provide protocol for storing, retrieving, and iterating over the collection. However, Tables in addition provide an organization for the Heapers collected together in the range of a Table: A Table can also be seen as a collection of associations between keys and values. A particular Table object has a particular domain coordinateSpace, and all keys in that Table are positions in that coordinate space. For each position in a Table''s coordinate space there is at most one value which it maps to. This value may be any arbitrary Heaper. The same Heaper may appear as value for several keys. When iterating over the contents of a Table with a Stepper, the normal elements enumerated by the Stepper are values (i.e., range elements) of the Table. However, ScruTable::stepper returns a TableStepper (a subclass of Stepper) which provides aditional protocol of accessing the key corresponding to the current value. (see ScruTable::stepper and TableStepper.)'! (ScruTable getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !ScruTable methodsFor: 'accessing'! {CoordinateSpace} coordinateSpace "The kind of elements used to index into the table are Positions of this coordinate space. Therefore, the domain of this table is an XuRegion in this coordinate space." self subclassResponsibility! {IntegerVar} count "Return the number of domain elements, which is to say, the number of associations. 'table->count()' should be equivalent to 'table->domain()->count()'. Used to say: 'Return the number of range elements'. This seems clearly wrong." self subclassResponsibility.! {XnRegion} domain "Return an XuRegion representing a snapshot of the current domain. 'table->domain()->hasMember(p)' iff 'table->fetch(p) !!= NULL'." self subclassResponsibility.! {Heaper} fetch: key {Position} "Return the range element at the domain position key. The routine will return NULL if the position is not in the table." self subclassResponsibility! {Heaper} get: key {Position} "Return the range element at the domain position key. BLAST if the position is not in the table." | tmp {Heaper wimpy} | tmp _ self fetch: key. tmp == NULL ifTrue: [Heaper BLAST: #NotInTable. ^NULL]. ^tmp! {ImmuSet of: Heaper} range "A snapshot of the current range elements of the table collected together into an ImmuSet." | acc {SetAccumulator} | acc _ SetAccumulator make. self stepper forEach: [:obj {Heaper} | acc step: obj]. ^acc value cast: ImmuSet! {ScruTable} subTable: region {XnRegion} "Return a table which contains only the intersection of this table's domain and the domain specified by 'region'. table->subTable(r)->domain()->isEqual( table->domain()->intersect(r) ). It is unspecified whether the resulting table starts as a snapshot of a subset of me, after which we go our own ways; or whether the resulting table is a view onto a subset of me, such that changes to me are also visible to him. Of course, subclasses may specify more. If you want to ensure snapshot behavior, do 'table->subTable(r)->asImmuTable()'. NOTE: In the future we may specify snapshot behavior or we may specify view behavior. As a client this shouldn't effect you. However, if you implement a new kind of ScruTable, please let us know. Also, if you have an opinion as to which way you'd like the specification tightened up, please tell us." self subclassResponsibility! {ScruTable} transformedBy: dsp {Dsp} "Return a ScruTable with the domain of the receiver transformed by the Dsp. 'table->transformedBy(d)->fetch(p)' is equivalent to 'table->fetch(d->of(p))'. See ScruTable::subTable for caveats regarding whether we return a snapshot or a view. All the same caveats apply." ^ OffsetScruTable create: self with: dsp! ! !ScruTable methodsFor: 'testing'! {UInt32} actualHashForEqual "See ScruTable::isEqual" ^Heaper takeOop! {BooleanVar} contentsEqual: other {ScruTable} "Returns whether the two ScruTables have exactly the same mapping from keys to values at the moment. 'a->contentsEqual(b)' is equivalent to 'a->asImmuTable()->isEqual(b->asImmuTable())'. See ScruTable::contentsEqual" | myStepper {TableStepper} otherValue {Heaper} | (other count ~= self count) ifTrue: [^false]. (other coordinateSpace isEqual: self coordinateSpace) ifFalse: [^false]. myStepper _ self stepper. [myStepper hasValue] whileTrue: [otherValue _ other fetch: myStepper position. otherValue == NULL ifTrue: [^false]. (otherValue isEqual: myStepper fetch) ifFalse: [^false]. myStepper step]. ^true! {UInt32} contentsHash "Has the same relationship to contentsEqual that hashForEqual has to isEqual. I.e., if 'a->contentsEqual (b)', then 'a->contentsHash() == b->contentsHash()'. The same complex caveats apply as to the stability and portability of the hash values as apply for hashForEqual. See ScruSet contentsHash." | dom {XnRegion} | dom _ self domain. dom isEmpty ifTrue: [^self coordinateSpace hashForEqual*17] ifFalse: [dom cast: IntegerRegion into: [ :ints | ^ints start DOTasLong + ints stop DOTasLong + self count DOTasLong + self coordinateSpace hashForEqual] others: [^self count DOTasLong + self coordinateSpace hashForEqual]]. ^UInt32Zero "fodder"! {BooleanVar} includesKey: key {Position} "includesKey is used to test for the presence of a key->value pair in the table. This routine returns true if there is a value present at the specified key, and false otherwise. 'table->includesKey(p)' iff 'table->domain()->hasMember(p)'." ^ (self fetch: key) ~~ NULL! {BooleanVar} isEmpty "Is there anything in the table? 'table->isEmpty()' iff 'table->domain()->isEmpty()'." self subclassResponsibility! {BooleanVar} isEqual: other {Heaper} "All MuTable subclasses have equality based on identity (now and forever equal. Many ScruTable subclasses will represent an aspect of another table. Therefore they have hashForEqual and isEqual: based on both their contained table, and the aspect that they represent. Thus, two similar views onto the same MuTable are now (and forever) equal. The hashForEqual: must use exactly the same aspects for the hash as get used for isEqual:. ImmuTables all use contentBased comparison operations." self subclassResponsibility! ! !ScruTable methodsFor: 'enumerating'! {TableStepper} stepper: order {OrderSpec default: NULL} "Return a TableStepper which will enumerate my key->value mappings. The Stepper component of the TableStepper protocol will just enumerate my values (as that is what I'm a container *of*--the keys are simply how I organize my contents). TableStepper provides additional protocol to ascetain the current key. See TableStepper and XuRegion::stepper. The TableStepper I produce given an order must enumerate keys according to the same rules which specify how XuRegion::stepper must enumerate positions. I am not asserting that the actual orders are the same, only that the correctness criteria on the allowable orders are the same. Keeping in mind that we are talking about equivalence of specification and not equivalence of particular behavior, the following two statements are equivalent: { SPTR(TableStepper) stomp = table->stepper(o); SPTR(Position) key; FOR_EACH(Heaper,val,stomp, { key = stomp->key(); doSomethingWith(key, val); }); } and { SPTR(Heaper) val; SPTR(ImmuTable) snapShot = table->asImmuTable(); FOR_EACH(Position,key,(snapShot->domain()->stepper(o)), { val = snapShot->get (key); doSomethingWith(key, val); }); } " self subclassResponsibility! {Heaper} theOne "Iff I contain exactly one range element, return it. Otherwise BLAST. The idea for this message is taken from the THE function of ONTIC (reference McAllester)" | stepper {TableStepper} result {Heaper} | self count ~~ 1 ifTrue: [ Heaper BLAST: #NotOneElement ]. stepper _ self stepper. result _ stepper fetch. stepper destroy. ^ result! ! !ScruTable methodsFor: 'conversion'! {ImmuTable} asImmuTable "Return a side-effect-free snapshot of my current contents. See ScruSet::asImmuSet." self subclassResponsibility! {MuTable} asMuTable "Return a side-effectable version of the same table. See ScruSet::asMuSet." self subclassResponsibility! ! !ScruTable methodsFor: 'smalltalk: backfollow'! {ScruTable} backfollowFrom: value {Heaper} "Return the subTable with the domain of all positions whose values are equal to value. Defined by analogy with corresponding Waldo-level operation." self unimplemented. "value == NULL ifTrue: [^self] ifFalse: [^BackfollowTable create: self with: value]"! ! !ScruTable methodsFor: 'printing'! {void} printOn: stream {ostream reference} stream << self getCategory name. self printOnWithSimpleSyntax: stream with: '(' with: ', ' with: ')'! {void} printOnWithSimpleSyntax: oo {ostream reference} with: open {char star} with: sep {char star} with: close {char star} "Print the contents of the table as key1 ""->"" value1 key2 ""->"" value2 ... keyN ""->"" valueN . For example, 'table->printOnWithSyntax(oo, ""{"", "", "", ""}"");' may result in '{3->Foo(), 5->Bar()}'. One wierd but convenient special case: if the domain space is an IntegerSpace, we print the keys according to the way IntegerVars print, not the way XuIntegers print. For yet more fine-grained control over printing, see the ScruTable::printOnWithSyntax with 5 arguments." self printOnWithSyntax: oo with: open with: '->' with: sep with: close.! {void} printOnWithSyntax: stream {ostream reference} with: open {char star} with: map {char star} with: sep {char star} with: close {char star} "Print the contents of the table as key1 value1 key2 value2 ... keyN valueN . For example, 'table->printOnWithSyntax(oo, ""{"", ""=>"", "", "", ""}"");' may result in '{3=>Foo(), 5=>Bar()}'. One wierd but convenient special case: if the domain space is an IntegerSpace, we print the keys according to the way IntegerVars print, not the way XuIntegers print." | stomp {TableStepper} | stream << open. self isEmpty ifFalse: [stomp _ self stepper. [stomp hasValue] whileTrue: [stomp position cast: IntegerPos into: [:xui | stream << xui asIntegerVar] others: [stream << stomp position]. stream << map << stomp fetch. stomp step. stomp hasValue ifTrue: [stream << sep]]. stomp destroy]. stream << close! ! !ScruTable methodsFor: 'runs'! {XnRegion} runAt: key {Position} "Return the length of the run starting at position key. A run is defined as a contiguous (charming) sequence of domain positions mapping to equal (isEqual) objects. Charming is defined as: Given a charming region R, for all a,c which are elements of R and a >= b >= c, b is an element of R. Where '>=' is according to the 'isGE' message. NOTE: We may retire the above definition of charming. The possible changes will only effect spaces which aren't fully ordered. OrderedRegions, TreeRegions, and IntegerRegions will be unaffected, as any future definition of 'runAt' will be equivalent for them." self subclassResponsibility! ! !ScruTable methodsFor: 'creation'! {ScruTable} copy "A new one whose initial state is my current state, but that doesn't track changes. Note that there is no implication that these can be 'destroy'ed separately, because (for example) an ImmuTable just returns itself" self subclassResponsibility! {ScruTable} emptySize: size {IntegerVar} "Return an empty table just like the current one. The 'size' argument is a hint about how big the count of the table will probably become (so that the new table can be prepared to grow to that size efficiently)." self subclassResponsibility! ! !ScruTable methodsFor: 'protected: creation'! create super create! ! !ScruTable methodsFor: 'overloads'! {BooleanVar} includesIntKey: aKey {IntegerVar} "Unboxed version. See class comment for XuInteger" ^self includesKey: aKey integer! {Heaper} intFetch: key {IntegerVar} "Unboxed version. See class comment for XuInteger" ^ self fetch: key integer! {Heaper} intGet: key {IntegerVar} "Unboxed version. See class comment for XuInteger" | tmp {Heaper wimpy} | tmp _ self intFetch: key. tmp == NULL ifTrue: [Heaper BLAST: #NotInTable. ^NULL]. ^tmp! {XnRegion} runAtInt: key {IntegerVar} "Unboxed version. See class comment for XuInteger" ^ self runAt: key integer! ! !ScruTable methodsFor: 'smalltalk: enumerating'! stepper "implement default argument of NULL" ^self stepper: NULL! ! !ScruTable methodsFor: 'smalltalk: special'! asOrderedCollection "convert for use with Smalltalk MVC stuff" | stomp {TableStepper} res {OrderedCollection} | res _ OrderedCollection new: self count. stomp _ self stepper. [stomp hasValue] whileTrue: [res add: stomp get. stomp step]. ^res.! {void} do: aBlock {BlockClosure of: Heaper} self stepper forEach: aBlock! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ScruTable class instanceVariableNames: ''! (ScruTable getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !ScruTable class methodsFor: 'exceptions: exceptions'! problems.NotInTable ^self signals: #(NotInTable)! !ScruTable subclass: #ImmuTable instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Tables'! ImmuTable comment: 'ImmuTable are to ScruTables much like ImmuSets are to ScruSets. See ImmuSet. The ImmuTable subclass of tables represents all tables which CANNOT be side-effected during operations on them. They are intended to represent mathematical abstractions (such as vectors) and are intended to be used in a functional-programming style. Operations are provided for building new ImmuTables out of old ones.'! (ImmuTable getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !ImmuTable methodsFor: 'accessing'! {CoordinateSpace} coordinateSpace self subclassResponsibility! {IntegerVar} count self subclassResponsibility.! {XnRegion} domain self subclassResponsibility.! {Heaper} fetch: key {Position} self subclassResponsibility! {Heaper} intFetch: key {IntegerVar} ^ super intFetch: key! {XnRegion} runAt: key {Position} self subclassResponsibility! {XnRegion} runAtInt: key {IntegerVar} ^ super runAtInt: key! {ScruTable} subTable: reg {XnRegion} self subclassResponsibility! {ScruTable} transformedBy: dsp {Dsp} "Return a ScruTable with the domain of the receiver transformed by the Dsp. 'table->transformedBy(d)->fetch(p)' is equivalent to 'table->fetch(d->of(p))'. See ScruTable::subTable for caveats regarding whether we return a snapshot or a view. All the same caveats apply. In this case of transforming an ImmuTable, it makes sense to return an ImmuTable." ^ OffsetImmuTable create: self with: dsp! ! !ImmuTable methodsFor: 'creation'! {ScruTable} copy "don't need to actually make a copy, as this is immutable" ^self! {ScruTable} emptySize: size {IntegerVar} "The idea of a 'size' argument would seem kind of ridiculous here as the resulting empty table can't be changed." self subclassResponsibility.! ! !ImmuTable methodsFor: 'SEF manipulation'! {ImmuTable} combineWith: other {ImmuTable} "Similar to unionWith. In particular, if 'a = b->combineWith(c);', then: 'a->domain()->isEqual(b->domain()->unionWith(c->domain())' and 'a->range()->isSubsetOf(b->range()->unionWith(c->range())'. (Note that the domain case uses XuRegion::unionWith, while the range case uses ImmuSet::unionWith.) Despite this correspondence, unionWith is symmetrical while combineWith is not. Given that the two input tables have different associations for a given key, one gets to dominate. I need to specify which one here, but the code seems inconsistent on this question. Until this is resolved, console youself with the thought that if the tables don't conflict we have a simple unionWith of the two sets of associations (and the 'isSubsetOf' above can be replaced with 'isEqual')." self subclassResponsibility! {ImmuTable} without: index {Position} "Return a new table just like the current one except with the association whose key is 'index'." self subclassResponsibility! ! !ImmuTable methodsFor: 'testing'! {UInt32} actualHashForEqual ^#cat.U.ImmuTable hashForEqual + self contentsHash! {BooleanVar} includesIntKey: aKey {IntegerVar} ^ super includesIntKey: aKey! {BooleanVar} includesKey: aKey {Position} self subclassResponsibility! {BooleanVar} isEmpty self subclassResponsibility.! {BooleanVar} isEqual: other {Heaper} other cast: ImmuTable into: [:o | ^self contentsEqual: o] others: [^false]. ^ false "compiler fodder"! ! !ImmuTable methodsFor: 'enumerating'! {TableStepper} stepper: order {OrderSpec default: NULL} self subclassResponsibility! ! !ImmuTable methodsFor: 'conversion'! {ImmuTable} asImmuTable ^self! {MuTable} asMuTable self subclassResponsibility! ! !ImmuTable methodsFor: 'smalltalk: passe'! {ImmuTable} with: other {ImmuTable} "Please use ImmuTable::combineWith instead. 'with' was an innapropriate name because its use elsewhere (see ImmuSet::with and XuRegion::with) implies that the argument is a single element to be added, not a collection of elements to be added." self passe. ^self combineWith: other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ImmuTable class instanceVariableNames: ''! (ImmuTable getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !ImmuTable class methodsFor: 'pseudo constructors'! {ImmuTable} make.CoordinateSpace: cs {CoordinateSpace} "An empty ImmuTable whose domain space is 'cs'." ^ImmuTableOnMu create: (MuTable make: cs)! {ImmuTable} offsetImmuTable: aTable {ImmuTable} with: aDsp {Dsp} ^ OffsetImmuTable create: aTable with: aDsp! ! !ImmuTable class methodsFor: 'smalltalk: smalltalk defaults'! make: something "(something isKindOf: MuTable) ifTrue: [^self make.MuTable: something]." ^self make.CoordinateSpace: (something cast: CoordinateSpace)! !ImmuTable subclass: #ImmuTableOnMu instanceVariableNames: 'myMuTable {MuTable}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Tables'! (ImmuTableOnMu getOrMakeCxxClassDescription) friends: 'friend SPTR(ImmuTable) immuTable (MuTable*); friend SPTR(ImmuTable) immuTable (CoordinateSpace * cs); friend SPTR(ImmuTable) MuTable::asImmuTable ();'; attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; add: #COPY; yourself)! !ImmuTableOnMu methodsFor: 'private: instance creation'! create: aMuTable {MuTable} "use the given Mu to store current value" "it should be a copy for my exclusive use" "this should only be called from the pseudo constructor or from class methods" super create. myMuTable _ aMuTable! ! !ImmuTableOnMu methodsFor: 'accessing'! {CoordinateSpace} coordinateSpace ^myMuTable coordinateSpace! {IntegerVar} count ^myMuTable count! {XnRegion} domain ^myMuTable domain! {Heaper} fetch: key {Position} ^myMuTable fetch: key! {Heaper} intFetch: key {IntegerVar} ^myMuTable intFetch: key! {ScruTable} subTable: region {XnRegion} ^ImmuTableOnMu create: ((myMuTable subTable: region) cast: MuTable)! ! !ImmuTableOnMu methodsFor: 'SEF manipulation'! {ImmuTable} combineWith: other {ImmuTable} | newMuTable {MuTable} others {TableStepper} | newMuTable _ myMuTable copy cast: MuTable. others _ other stepper. [others hasValue] whileTrue: [newMuTable at: others position store: others fetch. others step]. others destroy. ^ImmuTableOnMu create: newMuTable! {ImmuTable} without: index {Position} | newMuTable {MuTable} | newMuTable _ myMuTable copy cast: MuTable. newMuTable wipe: index. ^ ImmuTableOnMu create: newMuTable! ! !ImmuTableOnMu methodsFor: 'conversion'! {MuTable} asMuTable ^myMuTable copy cast: MuTable! ! !ImmuTableOnMu methodsFor: 'testing'! {BooleanVar} includesIntKey: aKey {IntegerVar} ^ myMuTable includesIntKey: aKey! {BooleanVar} includesKey: aKey {Position} ^ myMuTable includesKey: aKey! {BooleanVar} isEmpty ^myMuTable isEmpty! ! !ImmuTableOnMu methodsFor: 'enumerating'! {TableStepper} stepper: order {OrderSpec default: NULL} ^myMuTable copy stepper: order "making the copy prevents anyone from getting access to the array through TableStepper array"! {Heaper} theOne ^ myMuTable theOne! ! !ImmuTableOnMu methodsFor: 'private: accessing'! {MuTable} getMuTable ^myMuTable! ! !ImmuTableOnMu methodsFor: 'creation'! {ScruTable} emptySize: size {IntegerVar} ^ImmuTableOnMu create: ((myMuTable emptySize: size) cast: MuTable)! ! !ImmuTableOnMu methodsFor: 'runs'! {XnRegion} runAt: key {Position} ^myMuTable runAt: key! {XnRegion} runAtInt: key {IntegerVar} ^myMuTable runAtInt: key! ! !ImmuTableOnMu methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '(' << myMuTable << ')'! ! !ImmuTableOnMu methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myMuTable _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myMuTable.! !ImmuTable subclass: #OffsetImmuTable instanceVariableNames: ' myTable {ImmuTable} myDsp {Dsp}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Tables'! (OffsetImmuTable getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !OffsetImmuTable methodsFor: 'accessing'! {CoordinateSpace} coordinateSpace ^myTable coordinateSpace! {IntegerVar} count ^myTable count! {XnRegion} domain ^myDsp ofAll: myTable domain! {Heaper} fetch: anIndex {Position} ^myTable intFetch: (myDsp inverseOfInt: (anIndex cast: IntegerPos) asIntegerVar)! {Heaper} intFetch: idx {IntegerVar} ^myTable intFetch: (myDsp inverseOfInt: idx)! {ScruTable} subTable: encl {XnRegion} ^OffsetScruTable create: (myTable subTable: (myDsp inverseOfAll: encl)) with: myDsp.! {ScruTable} transformedBy: dsp {Dsp} (myDsp inverse isEqual: dsp) ifTrue: [^myTable] ifFalse: [^OffsetScruTable create: myTable with: (dsp compose: myDsp)]! ! !OffsetImmuTable methodsFor: 'runs'! {XnRegion} runAt: key {Position} (self includesKey: (myDsp inverseOf: key)) ifTrue: [^ key asRegion] ifFalse: [^ myTable coordinateSpace emptyRegion]! {XnRegion} runAtInt: anIdx {IntegerVar} ^myDsp ofAll: (myTable runAtInt: (myDsp inverseOfInt: anIdx))! ! !OffsetImmuTable methodsFor: 'testing'! {UInt32} actualHashForEqual ^#cat.U.OffsetImmuTable hashForEqual + myTable hashForEqual + myDsp hashForEqual! {BooleanVar} includesIntKey: aKey {IntegerVar} ^myTable includesIntKey: (myDsp inverseOfInt: aKey)! {BooleanVar} includesKey: aKey {Position} ^ myTable includesKey: (myDsp inverseOf: aKey)! {BooleanVar} isEmpty ^myTable isEmpty! ! !OffsetImmuTable methodsFor: 'printing'! {void} printOn: aStream {ostream reference} aStream << self getCategory name << '(' << myDsp << ', ' << myTable << ')'! ! !OffsetImmuTable methodsFor: 'creation'! create: table {ImmuTable} with: dsp {Dsp} super create. myTable _ table. myDsp _ dsp! {ScruTable} emptySize: size {IntegerVar} ^ myTable emptySize: size! ! !OffsetImmuTable methodsFor: 'conversion'! {MuTable} asMuTable | newTab {MuTable} s {TableStepper} | newTab _ (myTable emptySize: myTable count) asMuTable. (s _ myTable stepper) forEach: [ :e {Heaper} | newTab at: (myDsp of: s position) store: e]. ^ newTab! ! !OffsetImmuTable methodsFor: 'smalltalk: private:'! {TableStepper} stepper ^ OffsetScruTableStepper create.Stepper: (myTable stepper) with: myDsp! ! !OffsetImmuTable methodsFor: 'enumerating'! {TableStepper} stepper: order {OrderSpec default: NULL} ^OffsetScruTableStepper create.Stepper: (myTable stepper: order) with: myDsp! ! !OffsetImmuTable methodsFor: 'private: private'! {Dsp} innerDsp ^myDsp! {ScruTable} innerTable ^myTable! ! !OffsetImmuTable methodsFor: 'SEF manipulation'! {ImmuTable} combineWith: other {ImmuTable} | newTable {MuTable} others {TableStepper} | newTable _ myTable copy asMuTable. others _ other stepper. [others hasValue] whileTrue: [newTable at: (myDsp inverseOf: others position) store: others fetch. others step]. others destroy. ^OffsetImmuTable create: newTable asImmuTable with: myDsp! {ImmuTable} without: index {Position} ^OffsetImmuTable create: (myTable without: (myDsp inverseOf: index)) with: myDsp! !ScruTable subclass: #IntegerScruTable instanceVariableNames: 'tableToScru {IntegerTable}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Tables'! (IntegerScruTable getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; add: #COPY; yourself)! !IntegerScruTable methodsFor: 'accessing'! {CoordinateSpace} coordinateSpace ^IntegerSpace make! {IntegerVar} count ^tableToScru count! {XnRegion} domain ^ tableToScru domain! {Heaper} fetch: key {Position} ^ tableToScru fetch: key! {Heaper} intFetch: key {IntegerVar} ^ tableToScru intFetch: key! {ScruTable} subTable: reg {XnRegion} ^ tableToScru subTable: reg! {ScruTable} subTableBetween: start {IntegerVar} with: stop {IntegerVar} "Return a table which contains the intersection of this table's domain and the domain specified by the enclosure." ^ tableToScru offsetSubTableBetween: start with: stop with: start! ! !IntegerScruTable methodsFor: 'creation'! {ScruTable} copy ^ IntegerScruTable create: ((tableToScru copy) quickCast: IntegerTable)! create: fromTable {IntegerTable} super create. tableToScru _ fromTable! {ScruTable} emptySize: size {IntegerVar} ^ IntegerScruTable create.IntegerVar: ((tableToScru emptySize: size) quickCast: IntegerTable)! ! !IntegerScruTable methodsFor: 'runs'! {XnRegion} runAt: key {Position} ^ tableToScru runAt: key! {XnRegion} runAtInt: key {IntegerVar} ^ tableToScru runAtInt: key! ! !IntegerScruTable methodsFor: 'testing'! {UInt32} actualHashForEqual ^#cat.U.IntegerScruTable hashForEqual + tableToScru hashForEqual! {BooleanVar} includesIntKey: aKey {IntegerVar} ^ tableToScru includesIntKey: aKey! {BooleanVar} includesKey: aKey {Position} ^ tableToScru includesKey: aKey! {BooleanVar} isEmpty ^ tableToScru isEmpty! {BooleanVar} isEqual: other {Heaper} other cast: IntegerScruTable into: [:ist | ^ist innerTable isEqual: tableToScru] others: [^false]. ^ false "compiler fodder"! ! !IntegerScruTable methodsFor: 'enumerating'! {TableStepper} stepper: order {OrderSpec default: NULL} ^ tableToScru stepper: order! ! !IntegerScruTable methodsFor: 'conversion'! {ImmuTable} asImmuTable ^ tableToScru asImmuTable! {MuTable} asMuTable ^ tableToScru copy asMuTable! ! !IntegerScruTable methodsFor: 'private: private'! {ScruTable} innerTable ^tableToScru! ! !IntegerScruTable methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. tableToScru _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: tableToScru.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! IntegerScruTable class instanceVariableNames: ''! (IntegerScruTable getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; add: #COPY; yourself)! !IntegerScruTable class methodsFor: 'pseudo constructors'! {ScruTable} make: fromTable {IntegerTable} ^ IntegerScruTable create: fromTable! !ScruTable subclass: #MuTable instanceVariableNames: '' classVariableNames: ' AlreadyInTableSignal {Signal smalltalk} NotInDomainSignal {Signal smalltalk} NullInsertionSignal {Signal smalltalk} ' poolDictionaries: '' category: 'Xanadu-Collection-Tables'! MuTable comment: 'MuTable represents the base class for all side-effectable tables. It provides the basic change protocol for tables. See MuSet.'! (MuTable getOrMakeCxxClassDescription) friends: '/* friends for class MuTable */ friend class COWMuTable;'; attributes: ((Set new) add: #EQ; add: #DEFERRED; add: #COPY; yourself)! !MuTable methodsFor: 'accessing'! {void} at: key {Position} introduce: value {Heaper} "Associate key with value unless key is already associated with another value. If so, blast." | old {Heaper} | ((old _ self at: key store: value) ~~ NULL) ifTrue: [self at: key store: old. Heaper BLAST: #AlreadyInTable]! {void} at: key {Position} replace: value {Heaper} "Associate key with value only if key is already associated with a value. Otherwise blast." ((self at: key store: value) == NULL) ifTrue: [self wipe: key. "restore table before blast" Heaper BLAST: #NotInTable]! {Heaper} at: key {Position} store: value {Heaper} "Associate value with key, whether or not there is a previous association. Return the old range element if the position was previously occupied, NULL otherwise" self subclassResponsibility! {CoordinateSpace} coordinateSpace self subclassResponsibility! {IntegerVar} count self subclassResponsibility! {XnRegion} domain self subclassResponsibility.! {Heaper} fetch: key {Position} self subclassResponsibility! {void} remove: anIdx {Position} "Remove a key->value association from the table. Blast if the key is not present." (self wipe: anIdx) ifFalse: [Heaper BLAST: #NotInTable]! {ScruTable} subTable: reg {XnRegion} self subclassResponsibility! {BooleanVar} wipe: anIdx {Position} "Remove a key->value association from the table. Do not blast (or do anything else) if the key is not in my current domain. Return TRUE if the association was present and removed, Return FALSE if the association was not there" self subclassResponsibility! ! !MuTable methodsFor: 'bulk operations'! {void} introduceAll: table {ScruTable} with: dsp {Dsp default: NULL} with: region {XnRegion default: NULL} "'MuTable::introduceAll is to 'MuTable::introduce' as 'MuTable::storeAll' is to 'MuTable::store'. See MuTable::storeAll. In addition to the functionality provided by MuTable::storeAll, I BLAST *if* all the associations I'm being asked to store override existing associations of mine. If I BLAST for this reason, then I guarantee that I haven't changed myself at all." "Since this function checks the relavent regions, it can call the potentially more efficient store:" (table coordinateSpace isEqual: self coordinateSpace) ifFalse: [ Heaper BLAST: #WrongCoordSpace ]. dsp == NULL ifTrue: [(self domain intersects: table domain) ifTrue: [ Heaper BLAST: #AlreadyInTable ]] ifFalse: [region == NULL ifTrue: [(self domain intersects: (dsp ofAll: table domain)) ifTrue: [ Heaper BLAST: #AlreadyInTable ]] ifFalse: [(self domain intersects: (dsp ofAll: (table domain intersect: region))) ifTrue: [ Heaper BLAST: #AlreadyInTable ]]]. self storeAll: table with: dsp with: region! {void} replaceAll: table {ScruTable} with: dsp {Dsp default: NULL} with: region {XnRegion default: NULL} "'MuTable::replaceAll is to 'MuTable::replace' as 'MuTable::storeAll' is to 'MuTable::store'. See MuTable::storeAll. In addition to the functionality provided by MuTable::storeAll, I BLAST *unless* all the associations I'm being asked to store override existing associations of mine. If I BLAST for this reason, then I guarantee that I haven't changed myself at all." "Since this function checks the relavent regions, it can call the potentially more efficient store:" | stepper {TableStepper} | (table coordinateSpace isEqual: self coordinateSpace) ifFalse: [ Heaper BLAST: #WrongCoordSpace ]. dsp == NULL ifTrue: [(table domain isSubsetOf: self domain) ifFalse: [ Heaper BLAST: #AlreadyInTable ]. (stepper _ table stepper) forEach: [ :e {Heaper} | self at: stepper position store: e]] ifFalse: [region == NULL ifTrue: [((dsp ofAll: table domain) isSubsetOf: self domain) ifFalse: [ Heaper BLAST: #AlreadyInTable ]. (stepper _ table stepper) forEach: [ :x {Heaper} | self at: (dsp of: stepper position) store: x]] ifFalse: [((dsp ofAll: (table domain intersect: region)) isSubsetOf: self domain) ifFalse: [ Heaper BLAST: #AlreadyInTable ]. (stepper _ (table subTable: region) stepper) forEach: [ :y {Heaper} | self at: (dsp of: stepper position) store: y]]]! {void} storeAll: table {ScruTable} with: dsp {Dsp default: NULL} with: region {XnRegion default: NULL} "I 'store' into myself (see MuTable::store) all the associations from 'table'. If 'region' is provided, then I only store those associations from 'table' whose key is inside 'region'. If 'dsp' is provided, then I transform the keys (from the remaining associations) by dsp before storing into myself." | stepper {TableStepper} | (table coordinateSpace isEqual: self coordinateSpace) ifFalse: [ Heaper BLAST: #WrongCoordSpace ]. dsp == NULL ifTrue: [(stepper _ table stepper) forEach: [ :e {Heaper} | self at: stepper position store: e]] ifFalse: [| localTable {ScruTable} | region ~~ NULL ifTrue: [ localTable _ table subTable: region ] ifFalse: [ localTable _ table ]. (stepper _ localTable stepper) forEach: [ :x {Heaper} | self at: (dsp of: stepper position) store: x]]! {void} wipeAll: region {XnRegion} "I 'wipe' from myself all associations whose key is in 'region'. See MuTable::wipe" (region coordinateSpace isEqual: self coordinateSpace) ifFalse: [ Heaper BLAST: #WrongCoordSpace ]. region stepper forEach: [ :p {Position} | self wipe: p]! ! !MuTable methodsFor: 'testing'! {BooleanVar} includesKey: aKey {Position} self subclassResponsibility! {BooleanVar} isEmpty self subclassResponsibility.! ! !MuTable methodsFor: 'enumerating'! {TableStepper} stepper: order {OrderSpec default: NULL} self subclassResponsibility! ! !MuTable methodsFor: 'conversion'! {ImmuTable} asImmuTable ^ImmuTableOnMu create: (self copy cast: MuTable)! {MuTable} asMuTable "Note that muTable->asMuTable() returns a copy of the original. The two are now free to change independently." ^self copy quickCast: MuTable! ! !MuTable methodsFor: 'runs'! {XnRegion} runAt: key {Position} self subclassResponsibility! ! !MuTable methodsFor: 'creation'! {ScruTable} copy self subclassResponsibility! {ScruTable} emptySize: size {IntegerVar} self subclassResponsibility! ! !MuTable methodsFor: 'protected: creation'! create "Create a new table with an unspecified number of initial domain positions." super create.! ! !MuTable methodsFor: 'overloads'! {void} atInt: key {IntegerVar} introduce: value {Heaper} "Unboxed version. See class comment for XuInteger" self at: key integer introduce: value! {void} atInt: key {IntegerVar} replace: value {Heaper} "Unboxed version. See class comment for XuInteger" self at: key integer replace: value! {Heaper} atInt: aKey {IntegerVar} store: anObject {Heaper} "Unboxed version. See class comment for XuInteger" ^ self at: aKey integer store: anObject! {BooleanVar} includesIntKey: aKey {IntegerVar} ^self includesKey: aKey integer! {Heaper} intFetch: key {IntegerVar} ^ super intFetch: key! {void} intRemove: anIdx {IntegerVar} "Unboxed version. See class comment for XuInteger" self remove: anIdx integer! {BooleanVar} intWipe: anIdx {IntegerVar} "Unboxed version. See class comment for XuInteger" ^ self wipe: anIdx integer! {XnRegion} runAtInt: index {IntegerVar} ^self runAt: (index integer)! ! !MuTable methodsFor: 'smalltalk: defaults'! {void} introduceAll: other {ScruTable} self introduceAll: other with: NULL with: NULL! {void} introduceAll: table {ScruTable} with: dsp {Dsp default: NULL} | stepper {TableStepper} | (table coordinateSpace isEqual: self coordinateSpace) ifFalse: [Heaper BLAST: #WrongCoordSpace]. (self domain intersects: (dsp ofAll: table domain)) ifTrue: [Heaper BLAST: #AlreadyInTable]. dsp == NULL ifTrue: [(stepper _ table stepper) forEach: [:d {Heaper} | self at: stepper position introduce: d]] ifFalse: [(stepper _ table stepper) forEach: [:e {Heaper} | self at: (dsp of: stepper position) introduce: e]]! {void} removeAll: region {XnRegion} (region coordinateSpace isEqual: self coordinateSpace) ifFalse: [ Heaper BLAST: #WrongCoordSpace ]. (region isSubsetOf: self domain) ifFalse: [ Heaper BLAST: #NotInTable ]. region stepper forEach: [ :p {Position} | self remove: p]! {void} replaceAll: other {ScruTable} self replaceAll: other with: NULL with: NULL! {void} replaceAll: other {ScruTable} with: dsp {Dsp} self replaceAll: other with: dsp with: NULL! {void} storeAll: other {ScruTable} self storeAll: other with: NULL with: NULL! {void} storeAll: table {ScruTable} with: dsp {Dsp default: NULL} | stepper {TableStepper} | (table coordinateSpace isEqual: self coordinateSpace) ifFalse: [Heaper BLAST: #WrongCoordSpace]. dsp == NULL ifTrue: [(stepper _ table stepper) forEach: [:e {Heaper} | self at: (dsp of: stepper position) store: e]] ifFalse: [(stepper _ table stepper) forEach: [:x {Heaper} | self at: stepper position store: x]]! ! !MuTable methodsFor: 'generated:'! actualHashForEqual ^self asOop! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! isEqual: other ^self == other! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MuTable class instanceVariableNames: ''! (MuTable getOrMakeCxxClassDescription) friends: '/* friends for class MuTable */ friend class COWMuTable;'; attributes: ((Set new) add: #EQ; add: #DEFERRED; add: #COPY; yourself)! !MuTable class methodsFor: 'exceptions:'! problems.AlreadyInTable ^self signals: #(AlreadyInTable)! problems.NullInsertion ^self signals: #(NullInsertion)! ! !MuTable class methodsFor: 'smalltalk: testing'! test "Table test" | iTable | iTable _ IntegerTable make. iTable at: 0 introduce: #zero. iTable at: 1 introduce: #one. iTable at: 2 introduce: #two. iTable at: 3 introduce: #three. Transcript show: 'table printing:'; cr. Transcript print: iTable; cr; endEntry.! ! !MuTable class methodsFor: 'pseudo constructors'! {MuTable} make: cs {CoordinateSpace} "A new empty MuTable whose domain space is 'cs'." (cs isEqual: IntegerSpace make) ifTrue: [^IntegerTable make: 10] ifFalse: [^HashTable make.CoordinateSpace: cs]! {MuTable} make: cs {CoordinateSpace} with: reg {XnRegion} "Semantically identical to 'muTable(cs)'. 'reg' just provides a hint as to what part of the domain space the new table should expect to be occupied." (cs isEqual: IntegerSpace make) ifTrue: [^IntegerTable make.Region: (reg cast: IntegerRegion)] ifFalse: [^HashTable make.CoordinateSpace: cs]! ! !MuTable class methodsFor: 'smalltalk: initialization'! initTimeNonInherited self REQUIRES: IntegerSpace. "Used in pseudoconstructor" self REQUIRES: IntegerTable. self REQUIRES: HashTable.! !MuTable subclass: #GrandHashTable instanceVariableNames: ' grandNodes {PtrArray of: GrandNode} numNodes {Int32} nodeIndexShift {Int32} myTally {Counter} myDoublingFrontIndex {Counter} myDoublingPasses {Counter} myCs {CoordinateSpace} cacheHash {UInt32 NOCOPY} cacheKey {Position NOCOPY wimpy} cacheValue {Heaper NOCOPY wimpy} myOutstandingSteppers {IntegerVar NOCOPY}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Grand'! (GrandHashTable getOrMakeCxxClassDescription) friends: '/* friends for class GrandHashTable */ friend SPTR(GrandHashTable) grandHashTable (CoordinateSpace *); friend SPTR(GrandHashTable) grandHashTable (CoordinateSpace *, Int4 nNodes); friend class GrandHashTableStepper;'; attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !GrandHashTable methodsFor: 'adding-removing'! {Heaper} at: aKey {Position} store: aHeaper {Heaper} | hash {UInt32} node {GrandNode} newEntry {GrandEntry} old {Heaper} | self checkSteppers. aHeaper == NULL ifTrue: [Heaper BLAST: #NullInsertion]. hash _ ExponentialHashMap exponentialMap: aKey hashForEqual. node _ (grandNodes fetch: hash // nodeIndexShift) cast: GrandNode. old _ node fetch: aKey with: hash. DiskManager consistent: 1 with: [newEntry _ GrandTableEntry make: aHeaper with: aKey with: hash]. node store.Entry: newEntry. old == NULL ifTrue: [myTally increment. self considerNeedForDoubling]. self invalidateCache. ^ old! {BooleanVar} wipe: aKey {Position} | hash {UInt32} node {GrandNode} | self checkSteppers. hash _ ExponentialHashMap exponentialMap: aKey hashForEqual. node _ (grandNodes fetch: hash // nodeIndexShift) cast: GrandNode. (node fetch: aKey with: hash) ~~ NULL ifTrue: [node wipe: aKey with: hash. myTally decrement. ^ true]. ^ false! ! !GrandHashTable methodsFor: 'accessing'! {CoordinateSpace} coordinateSpace ^ myCs! {IntegerVar} count ^myTally count! {XnRegion} domain | result {XnRegion} stepper {TableStepper} | result _ self coordinateSpace emptyRegion. (stepper _ self stepper cast: TableStepper) forEach: [ :elem {Heaper} | result _ result with: (stepper position)]. ^ result! {Heaper} fetch: key {Position} | hash {UInt32} result {Heaper} | hash _ ExponentialHashMap exponentialMap: key hashForEqual. "(cacheKey ~~ NULL and: [cacheHash == hash and: [cacheKey isEqual: key]]) ifTrue: [ ^ cacheValue ]. " result _ ((grandNodes fetch: hash // nodeIndexShift) cast: GrandNode) fetch: key with: hash. "result ~~ NULL ifTrue: [cacheHash _ hash. cacheKey _ key. cacheValue _ result]." ^ result! {ScruTable} subTable: region {XnRegion} | newTable {GrandHashTable} elements {TableStepper} | newTable _ GrandHashTable make.CoordinateSpace: myCs with: 8. elements _ self stepper. elements forEach: [:elemValue {Heaper} | (region hasMember: elements position) ifTrue: [newTable at: elements position store: elemValue]]. ^newTable! ! !GrandHashTable methodsFor: 'testing'! {BooleanVar} includesIntKey: aKey {IntegerVar} ^super includesIntKey: aKey! {BooleanVar} includesKey: aKey {Position} ^ (self fetch: aKey) ~~ NULL! {BooleanVar} isEmpty ^myTally count == IntegerVar0! ! !GrandHashTable methodsFor: 'creation'! {ScruTable} copy | newTable {GrandHashTable} s {TableStepper} | newTable _ GrandHashTable make: myCs with: numNodes. (s _ self stepper) forEach: [:e {Heaper} | newTable at: (s position) store: e]. ^ newTable! {ScruTable} emptySize: size {IntegerVar unused} ^ GrandHashTable make: myCs! ! !GrandHashTable methodsFor: 'printing'! {void} printOn: aStream {ostream reference} aStream << 'GrandHashTable(' << self count << ' entries over ' << numNodes << ' nodes)'! ! !GrandHashTable methodsFor: 'runs'! {XnRegion} runAt: index {Position} (self includesKey: index) ifTrue: [^ index asRegion] ifFalse: [^ myCs emptyRegion]! {XnRegion} runAtInt: index {IntegerVar} ^super runAtInt: index! ! !GrandHashTable methodsFor: 'private: enumerating'! {void INLINE} checkSteppers myOutstandingSteppers > IntegerVar0 ifTrue: [ Heaper BLAST: #ModifyBlockedByOutstandingStepper ]! {void} fewerSteppers myOutstandingSteppers _ myOutstandingSteppers - 1. myOutstandingSteppers < IntegerVar0 ifTrue: [ Heaper BLAST: #TooManySteppersReleased ]! {void} moreSteppers myOutstandingSteppers _ myOutstandingSteppers + 1! ! !GrandHashTable methodsFor: 'enumerating'! {TableStepper} stepper: order {OrderSpec unused default: NULL} ^ GrandHashTableStepper create: self! ! !GrandHashTable methodsFor: 'protected: creation'! create: cs {CoordinateSpace} with: nNodes {Int32} | aNode {GrandNode} | super create. myCs _ cs. numNodes _ nNodes. nodeIndexShift _ ExponentialHashMap hashBits // numNodes. grandNodes _ PtrArray nulls: numNodes. DiskManager consistent: 2 * numNodes + 3 with: [Int32Zero almostTo: numNodes do: [:i {Int32} | aNode _ GrandNode make. grandNodes at: i store: aNode]. myTally _ Counter make. myDoublingFrontIndex _ Counter make. myDoublingPasses _ Counter make]. myOutstandingSteppers _ IntegerVarZero. self invalidateCache! {void} destruct | temp {Heaper} | DiskManager consistent: numNodes with: [UInt32Zero almostTo: numNodes do: [:i {UInt32} | (temp _ grandNodes fetch: i) ~~ NULL ifTrue: [temp destroy]]]. super destruct! ! !GrandHashTable methodsFor: 'private: housekeeping'! {void} considerNeedForDoubling "Compute location of doubling front from tally. If front crosses a node boundary" " and that node has index higher than doublingFrontIndex then double that node." " Then increase doublingFrontIndex. If the front has hit the end of the table index" " reset it to zero. This allows elements to be wiped from the table without causing" " extra node doubling to occur on later insertions. This aims for 80% max table" "loading using an approximation of the formula given in the Fagin paper." | desiredDoublingIndex {Int32} x {IEEEDoubleVar} dfi {Int32} | x _ 0.05"Magic number" * numNodes * (1 bitShift: myDoublingPasses count DOTasLong) * GrandNode primaryPageSize. desiredDoublingIndex _ (myTally count DOTasLong asFloat / x) asInteger "- 1". dfi _ myDoublingFrontIndex count DOTasLong. desiredDoublingIndex >= (dfi + 1) ifTrue: [(grandNodes fetch: dfi) ~~ NULL ifTrue: [(GrandNodeDoubler make: ((grandNodes fetch: dfi) cast: GrandNode)) schedule]. dfi _ myDoublingFrontIndex increment DOTasLong]. dfi >= numNodes ifTrue: [myDoublingFrontIndex setCount: IntegerVar0. myDoublingPasses increment]! {void} invalidateCache cacheKey _ NULL.! ! !GrandHashTable methodsFor: 'hooks:'! {void RECEIVE.HOOK} restartGrandHashTable: trans {Rcvr unused default: NULL} "re-initialize the non-persistent part" cacheKey _ NULL. myOutstandingSteppers _ IntegerVar0! ! !GrandHashTable methodsFor: 'private: friendly'! {GrandNode} nodeAt: idx {IntegerVar} ^ (grandNodes fetch: idx DOTasLong) cast: GrandNode! {IntegerVar} nodeCount ^ numNodes! ! !GrandHashTable methodsFor: 'private: smalltalk: private'! {void} inspect (Sensor ctrlDown) ifTrue: [^EntView make: self]. ^InspectorView open: (HashTableInspector inspect: self)! inspectPieces ^grandNodes asOrderedCollection! ! !GrandHashTable methodsFor: 'conversion'! {ImmuTable} asImmuTable self willNotImplement. ^ NULL! {MuTable} asMuTable self willNotImplement. ^ NULL! ! !GrandHashTable methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. grandNodes _ receiver receiveHeaper. numNodes _ receiver receiveInt32. nodeIndexShift _ receiver receiveInt32. myTally _ receiver receiveHeaper. myDoublingFrontIndex _ receiver receiveHeaper. myDoublingPasses _ receiver receiveHeaper. myCs _ receiver receiveHeaper. self restartGrandHashTable: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: grandNodes. xmtr sendInt32: numNodes. xmtr sendInt32: nodeIndexShift. xmtr sendHeaper: myTally. xmtr sendHeaper: myDoublingFrontIndex. xmtr sendHeaper: myDoublingPasses. xmtr sendHeaper: myCs.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GrandHashTable class instanceVariableNames: ''! (GrandHashTable getOrMakeCxxClassDescription) friends: '/* friends for class GrandHashTable */ friend SPTR(GrandHashTable) grandHashTable (CoordinateSpace *); friend SPTR(GrandHashTable) grandHashTable (CoordinateSpace *, Int4 nNodes); friend class GrandHashTableStepper;'; attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !GrandHashTable class methodsFor: 'pseudoConstructors'! {GrandHashTable} make: cs {CoordinateSpace} ^ GrandHashTable create: cs with: 32 "A Very big table"! {GrandHashTable} make: cs {CoordinateSpace} with: nNodes {Int32} ^ GrandHashTable create: cs with: nNodes! ! !GrandHashTable class methodsFor: 'smalltalk: initialization'! initTimeNonInherited "GrandHashTable initTimeNonInherited" self REQUIRES: ExponentialHashMap! !MuTable subclass: #HashTable instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Tables'! (HashTable getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !HashTable methodsFor: 'accessing'! {Heaper} at: key {Position} store: value {Heaper} "Associate value with key, whether or not there is a previous association." self subclassResponsibility! {CoordinateSpace} coordinateSpace self subclassResponsibility! {IntegerVar} count self subclassResponsibility! {XnRegion} domain self subclassResponsibility.! {Heaper} fetch: key {Position} self subclassResponsibility! {ScruTable} subTable: reg {XnRegion} self subclassResponsibility! {BooleanVar} wipe: anIdx {Position} "Remove a key->value association from the table. Do not blast (or do anything else) if the key is not in my current domain." self subclassResponsibility! ! !HashTable methodsFor: 'testing'! {BooleanVar} includesKey: aKey {Position} self subclassResponsibility! {BooleanVar} isEmpty self subclassResponsibility.! ! !HashTable methodsFor: 'enumerating'! {TableStepper} stepper: order {OrderSpec default: NULL} self subclassResponsibility! {Heaper} theOne self subclassResponsibility! ! !HashTable methodsFor: 'runs'! {XnRegion} runAt: key {Position} self subclassResponsibility! ! !HashTable methodsFor: 'creation'! {ScruTable} copy self subclassResponsibility! {ScruTable} emptySize: size {IntegerVar} self subclassResponsibility! ! !HashTable methodsFor: 'protected: create'! create super create! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HashTable class instanceVariableNames: ''! (HashTable getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !HashTable class methodsFor: 'pseudo constructors'! {HashTable INLINE} make.CoordinateSpace: cs {CoordinateSpace} ^ActualHashTable make: cs! make.CoordinateSpace: cs {CoordinateSpace} with: size {IntegerVar} ^ActualHashTable make: cs with: (size DOTasLong bitOr: 1)! ! !HashTable class methodsFor: 'smalltalk: initialization'! initTimeNonInherited self REQUIRES: ImmuSet. "for the empty set domain" self REQUIRES: LPPrimeSizeProvider! !HashTable subclass: #ActualHashTable instanceVariableNames: ' myHashEntries {SharedPtrArray NOCOPY} myTally {Int32} myCoordinateSpace {CoordinateSpace}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Tables'! ActualHashTable comment: 'The HashTable is an implementation class that is intended to provide the weakest Position->Object mapping. It can map from arbitrary Position classes (such as HeaperAsPosition or TreePosition). HashTable can also be used for very sparse integer domains. HashTable, and the entire hashtab module, is private implementation. Not to be included by clients.'! (ActualHashTable getOrMakeCxxClassDescription) friends: '/* friends for class HashTable */ friend SPTR(HashTable) actualHashTable (APTR(CoordinateSpace) cs); friend SPTR(HashTable) actualHashTable (APTR(CoordinateSpace) cs, IntegerVar size); '; attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !ActualHashTable methodsFor: 'accessing'! {Heaper | NULL} at: key {Position} store: aHeaper {Heaper} | offset {Int32} entry {TableEntry | NULL} prev {TableEntry | NULL} | aHeaper == NULL ifTrue: [Heaper BLAST: #NullInsertion]. self aboutToWrite. self checkSize. offset _ key hashForEqual \\ myHashEntries count. entry _ (myHashEntries fetch: offset) cast: TableEntry. prev _ NULL. [entry ~~ NULL] whileTrue: [(entry match: key) ifTrue: [| result {Heaper} | result _ entry value. (entry replaceValue: aHeaper) ifFalse: ["Replace the whole entry object if it cannot be side-effected in place." | newEntry {TableEntry} | newEntry _ TableEntry make: key with: aHeaper. newEntry setNext: entry fetchNext. prev == NULL ifTrue: [myHashEntries at: offset store: newEntry] ifFalse: [prev setNext: newEntry]. entry destroy.]. ^result]. prev _ entry. entry _ entry fetchNext]. entry _ TableEntry make: key with: aHeaper. entry setNext: ((myHashEntries fetch: offset) cast: TableEntry). myHashEntries at: offset store: entry. myTally _ myTally + 1. ^NULL! {Heaper | NULL} atInt: key {IntegerVar} store: aHeaper {Heaper} | offset {Int32} entry {TableEntry | NULL} prev {TableEntry | NULL} | aHeaper == NULL ifTrue: [Heaper BLAST: #NullInsertion]. self aboutToWrite. self checkSize. offset _ (IntegerPos integerHash: key) \\ myHashEntries count. entry _ (myHashEntries fetch: offset) cast: TableEntry. prev _ NULL. [entry ~~ NULL] whileTrue: [(entry matchInt: key) ifTrue: [| result {Heaper} | result _ entry value. (entry replaceValue: aHeaper) ifFalse: ["Replace the whole entry object if it cannot be side-effected in place." | newEntry {TableEntry} | newEntry _ TableEntry make.IntegerVar: key with: aHeaper. newEntry setNext: entry fetchNext. prev == NULL ifTrue: [myHashEntries at: offset store: newEntry] ifFalse: [prev setNext: newEntry]. entry destroy.]. ^result]. prev _ entry. entry _ entry fetchNext]. entry _ TableEntry make.IntegerVar: key with: aHeaper. entry setNext: ((myHashEntries fetch: offset) cast: TableEntry). myHashEntries at: offset store: entry. myTally _ myTally + 1. ^NULL! {CoordinateSpace} coordinateSpace ^ myCoordinateSpace! {IntegerVar} count ^ Integer IntegerVar: myTally! {XnRegion} domain |keys {TableStepper} | keys _ self stepper. (self coordinateSpace == IntegerSpace make) ifTrue: [|result {IntegerRegion} | result _ IntegerRegion make. [keys hasValue] whileTrue: [result _ (result withInt: keys index) cast: IntegerRegion. "This is stupid, I should not need a cast here" keys step]. keys destroy. ^result] ifFalse: [|result {XnRegion} | result _ self coordinateSpace emptyRegion. [keys hasValue] whileTrue: [result _ result with: keys position. keys step]. keys destroy. ^ result].! {Heaper | NULL} fetch: key {Position} | offset {Int32} entry {TableEntry wimpy} | offset _ key hashForEqual \\ myHashEntries count. entry _ (myHashEntries fetch: offset) cast: TableEntry. [entry ~~ NULL] whileTrue: [(entry match: key) ifTrue: [^entry value]. entry _ entry fetchNext]. ^NULL! {Heaper | NULL} intFetch: key {IntegerVar} | offset {Int32} entry {TableEntry wimpy} | offset _ (IntegerPos integerHash: key) \\ myHashEntries count. entry _ (myHashEntries fetch: offset) cast: TableEntry. [entry ~~ NULL] whileTrue: [(entry matchInt: key) ifTrue: [^entry value]. entry _ entry fetchNext]. ^NULL! {ScruTable} subTable: region {XnRegion} | newTable {HashTable} elements {TableStepper} | newTable _ HashTable make.CoordinateSpace: myCoordinateSpace with: region count. elements _ self stepper. elements forEach: [:elemValue {Heaper} | (region hasMember: elements position) ifTrue: [newTable at: elements position store: elemValue]]. ^newTable! {BooleanVar} wipe: aKey {Position} | offset {UInt32} prev {TableEntry wimpy | NULL} entry {TableEntry wimpy | NULL} | offset _ aKey hashForEqual \\ myHashEntries count. entry _ (myHashEntries fetch: offset) cast: TableEntry. prev _ NULL. [entry ~~ NULL] whileTrue: [(entry match: aKey) ifTrue: [self aboutToWrite. prev == NULL ifTrue: [myHashEntries at: offset store: entry fetchNext] ifFalse: [prev setNext: entry fetchNext]. entry destroy. myTally _ myTally - 1. ^true]. prev _ entry. entry _ entry fetchNext]. ^false! ! !ActualHashTable methodsFor: 'testing'! {UInt32} fastHash | result {UInt32 register} entry {TableEntry wimpy} | result _ self getCategory hashForEqual + myTally. Int32Zero almostTo: myHashEntries count do: [:i {Int32} | entry _ (myHashEntries fetch: i) cast: TableEntry. [entry ~~ NULL] whileTrue: [result _ result + entry hashForEqual. entry _ entry fetchNext]]. ^result! {BooleanVar} includesKey: aKey {Position} ^ (self fetch: aKey) ~~ NULL! {BooleanVar} isEmpty ^ myTally == Int32Zero! ! !ActualHashTable methodsFor: 'creation'! {ScruTable} copy ^ActualHashTable create: myHashEntries with: self count DOTasLong with: self coordinateSpace! {ScruTable} emptySize: size {IntegerVar} ^ActualHashTable make: myCoordinateSpace with: size! ! !ActualHashTable methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name. self printOnWithSimpleSyntax: oo with: '[' with: ', ' with: ']'! ! !ActualHashTable methodsFor: 'runLength'! {XnRegion} runAt: index {Position} (self includesKey: index) ifTrue: [^ index asRegion] ifFalse: [^ myCoordinateSpace emptyRegion]! ! !ActualHashTable methodsFor: 'enumerating'! {TableStepper} stepper: order {OrderSpec default: NULL} "ignore order spec for now" order == NULL ifTrue: [^ TableEntry bucketStepper: myHashEntries] ifFalse: [self unimplemented]. ^NULL "fodder"! {Heaper} theOne | entry {TableEntry wimpy} | myTally ~~ 1 ifTrue: [Heaper BLAST: #NotOneElement]. Int32Zero almostTo: myHashEntries count do: [:index {Int32} | (entry _ (myHashEntries fetch: index) cast: TableEntry) ~~ NULL ifTrue: [^entry value]]. ^ NULL. "Keep the compiler quiet"! ! !ActualHashTable methodsFor: 'hooks:'! {void RECEIVE.HOOK} receiveHashTable: rcvr {Rcvr} "This currently doesn't take advantage of the optimizations in TableEntries. It should." myHashEntries _ SharedPtrArray make: myTally // 2 + 1. myHashEntries shareMore. (myCoordinateSpace isEqual: IntegerSpace make) ifTrue: [myTally timesRepeat: [| index {IntegerVar} | index _ rcvr receiveIntegerVar. self storeEntry: (TableEntry make.IntegerVar: index with: rcvr receiveHeaper)]] ifFalse: [myTally timesRepeat: [| key {Position} | key _ rcvr receiveHeaper cast: Position. self storeEntry: (TableEntry make: key with: rcvr receiveHeaper)]]! {void SEND.HOOK} sendHashTable: xmtr {Xmtr} "This currently doesn't take advantage of the optimizations in TableEntries. It should." (myCoordinateSpace isEqual: IntegerSpace make) ifTrue: [self stepper forIndices: [:index {IntegerVar} :value {Heaper} | xmtr sendIntegerVar: index. xmtr sendHeaper: value]] ifFalse: [self stepper forPositions: [:p {Position} :v {Heaper} | xmtr sendHeaper: p. xmtr sendHeaper: v]]! ! !ActualHashTable methodsFor: 'protected:'! create: entries {SharedPtrArray of: TableEntry} with: tally {Int32} with: cs {CoordinateSpace} super create. myHashEntries _ entries. myTally _ tally. myCoordinateSpace _ cs. myHashEntries shareMore! {void} destruct myHashEntries shareLess. super destruct! ! !ActualHashTable methodsFor: 'private:'! {void} aboutToWrite "If my contents are shared, and I'm about to change them, make a copy of them." myHashEntries shareCount > 1 ifTrue: [| newEntries {SharedPtrArray of: TableEntry} entryCount {Int32} | entryCount _ myHashEntries count. newEntries _ SharedPtrArray make: entryCount. Int32Zero almostTo: entryCount do: [:index {Int32} | | entry {TableEntry wimpy} | (entry _ (myHashEntries fetch: index) cast: TableEntry) ~~ NULL ifTrue: [| newEntry {TableEntry} | newEntry _ entry copy. newEntries at: index store: newEntry. entry _ entry fetchNext. [entry ~~ NULL] whileTrue: [newEntry setNext: entry copy. newEntry _ newEntry fetchNext. entry _ entry fetchNext]]]. myHashEntries shareLess. myHashEntries _ newEntries. myHashEntries shareMore]! {void} checkSize | oldEntries {SharedPtrArray} oldSize {Int32} newSize {Int32} | myTally > (myHashEntries count * 2) ifTrue: [oldSize _ myHashEntries count. newSize _ LPPrimeSizeProvider make uInt32PrimeAfter: (oldSize * 4). myHashEntries shareLess. oldEntries _ myHashEntries. myHashEntries _ SharedPtrArray make: newSize. myHashEntries shareMore. Int32Zero almostTo: oldSize do: [:j {Int32} | | cur {TableEntry} next {TableEntry} | cur _ (oldEntries fetch: j) cast: TableEntry. [cur ~~ NULL] whileTrue: [next _ cur fetchNext. self storeEntry: cur. cur _ next]]. oldEntries destroy]! {void} storeEntry: anEntry {TableEntry} "Store the tableentry into the entry table" | index {UInt32} | index _ anEntry position hashForEqual \\ myHashEntries count. anEntry setNext: ((myHashEntries fetch: index) cast: TableEntry). myHashEntries at: index store: anEntry! ! !ActualHashTable methodsFor: 'smalltalk: private:'! {void} inspect ^InspectorView open: (HashTableInspector inspect: self)! ! !ActualHashTable methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myTally _ receiver receiveInt32. myCoordinateSpace _ receiver receiveHeaper. self receiveHashTable: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendInt32: myTally. xmtr sendHeaper: myCoordinateSpace. self sendHashTable: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ActualHashTable class instanceVariableNames: ''! (ActualHashTable getOrMakeCxxClassDescription) friends: '/* friends for class HashTable */ friend SPTR(HashTable) actualHashTable (APTR(CoordinateSpace) cs); friend SPTR(HashTable) actualHashTable (APTR(CoordinateSpace) cs, IntegerVar size); '; attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !ActualHashTable class methodsFor: 'creation'! {HashTable} make: cs {CoordinateSpace} ^self create: (SharedPtrArray make: 7) with: Int32Zero with: cs! {HashTable} make: cs {CoordinateSpace} with: size {IntegerVar} ^self create: (SharedPtrArray make: (LPPrimeSizeProvider make uInt32PrimeAfter: (size DOTasLong))) with: Int32Zero with: cs! !MuTable subclass: #IntegerTable instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Tables'! IntegerTable comment: 'The IntegerTable class is used for tables that have arbitrary XuInteger keys in their domain. Since ScruTable & MuTable already provide all the unboxed versions of the table protocol, there is little need for this class to be a type. However, this class does provide a bit of extra protocol convenience: highestIndex & lowestIndex. Unless these are retired, we cannot retire this class from type status. Note that there may be tables with XuInteger keys (i.e., IntegerSpace domains) which are not kinds of IntegerTables. In particular it is perfectly sensible to create a HashTable with XuInteger keys when the domain region is likely to be sparse.'! (IntegerTable getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !IntegerTable methodsFor: 'accessing'! {void} atInt: key {IntegerVar} introduce: value {Heaper} | old {Heaper} | (old _ self atInt: key store: value) ~~ NULL ifTrue: [self atInt: key store: old. "restore prior condition" Heaper BLAST: #AlreadyInTable]! {void} atInt: key {IntegerVar} replace: value {Heaper} (self atInt: key store: value) == NULL ifTrue: [self intWipe: key. "restore prior condition" Heaper BLAST: #NotInTable]! {Heaper} atInt: key {IntegerVar} store: value {Heaper} self subclassResponsibility! {CoordinateSpace} coordinateSpace ^IntegerSpace make! {IntegerVar} count self subclassResponsibility! {XnRegion} domain self subclassResponsibility.! {IntegerVar} highestIndex "Given that the table is non-empty, 'intTab->highestIndex()' is equivalent to 'CAST(IntegerRegion,intTab->domain())->upperBound() -1'. The reason for the '-1' is that the 'upperBound' is an exclusive upper bound (see IntegerRegion::upperBound), whereas 'highestIndex' is the highest index which is in my domain. I need to here specify what 'highestIndex' does if I am empty." self subclassResponsibility! {Heaper} intFetch: key {IntegerVar} self subclassResponsibility! {void} intRemove: anIdx {IntegerVar} (self intWipe: anIdx) ifFalse: [Heaper BLAST: #NotInTable]! {BooleanVar} intWipe: anIdx {IntegerVar} self subclassResponsibility! {IntegerVar} lowestIndex "Given that the table is non-empty, 'intTab->lowestIndex()' is equivalent to 'CAST(IntegerRegion,intTab->domain())->lowerBound()'. 'lowestIndex' is the lowest index which is in my domain. I need to here specify what 'lowestIndex' does if I am empty." self subclassResponsibility! {ScruTable} subTable: reg {XnRegion} self subclassResponsibility! ! !IntegerTable methodsFor: 'accessing overloads'! {void} at: key {Position} introduce: value {Heaper} self atInt: (key cast: IntegerPos) asIntegerVar introduce: value! {void} at: key {Position} replace: value {Heaper} self atInt: (key cast: IntegerPos) asIntegerVar replace: value! {Heaper} at: key {Position} store: value {Heaper} ^ self atInt: (key cast: IntegerPos) asIntegerVar store: value! {Heaper} fetch: key {Position} ^ self intFetch: (key cast: IntegerPos) asIntegerVar! {BooleanVar} includesKey: aKey {Position} ^ self includesIntKey: (aKey cast: IntegerPos) asIntegerVar! {void} remove: aPos {Position} self intRemove: (aPos cast: IntegerPos) asIntegerVar! {XnRegion} runAt: key {Position} ^ self runAtInt: (key cast: IntegerPos) asIntegerVar! {BooleanVar} wipe: anIdx {Position} ^ self intWipe: ((anIdx cast: IntegerPos) asIntegerVar)! ! !IntegerTable methodsFor: 'testing'! {BooleanVar} includesIntKey: aKey {IntegerVar} self subclassResponsibility! {BooleanVar} isEmpty self subclassResponsibility.! ! !IntegerTable methodsFor: 'enumerating'! {TableStepper} stepper: order {OrderSpec default: NULL} self subclassResponsibility! ! !IntegerTable methodsFor: 'runs'! {XnRegion} runAtInt: key {IntegerVar} self subclassResponsibility! ! !IntegerTable methodsFor: 'creation'! {ScruTable} copy self subclassResponsibility! create "Create a new table with an unspecified number of initial domain positions." super create! {ScruTable} emptySize: size {IntegerVar} self subclassResponsibility! {ScruTable} offsetSubTableBetween: startIndex {IntegerVar} with: stopIndex {IntegerVar} with: firstIndex {IntegerVar} "Return a table which contains the elements from start to stop, starting at firstIndex. Zero-based subclasses will blast if firstIndex is non-zero" self subclassResponsibility! {ScruTable} subTableBetween: startIndex {IntegerVar} with: stopIndex {IntegerVar} "Hack for C++ overloading problem" self subclassResponsibility! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! IntegerTable class instanceVariableNames: ''! (IntegerTable getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !IntegerTable class methodsFor: 'smalltalk: pseudoConstructors'! {IntegerTable} make: something {Heaper} (something isKindOf: String) ifTrue: [^ self make.charVector: something]. ^ self make.IntegerVar: (something cast: Integer)! {MuTable} make: from {IntegerVar} with: to {IntegerVar} ^self make.IntegerVar: from with: to! ! !IntegerTable class methodsFor: 'pseudoConstructors'! {IntegerTable} make "A new empty IntegerTable" ^ ActualIntegerTable create.! {IntegerTable} make.IntegerVar: someSize {IntegerVar} "A new empty IntegerTable. 'someSize' is a hint about how big the table is likely to need to be ('highestIndex - lowestIndex + 1', not 'count')." ^ActualIntegerTable create.IntegerVar: someSize! {IntegerTable} make.IntegerVar: fromIdx {IntegerVar} with: toIdx {IntegerVar} "Hint that the domain's lowerBound (inclusive) will eventually be 'fromIdx', and the domain's upperBound (exclusive) will eventually be 'toIdx'." ^ActualIntegerTable create: fromIdx with: toIdx! {IntegerTable} make.Region: reg {IntegerRegion} "Hint that the domain of the new table will eventually be (or at least resemble) 'reg'." ^ActualIntegerTable create: reg start with: reg stop! ! !IntegerTable class methodsFor: 'smalltalk: passe'! {IntegerTable} make.ScruTable: table {ScruTable} "A new IntegerTable initialized from 'table' in a wierd and screwy way" "| newTable {IntegerTable} stomp {TableStepper} | newTable _ IntegerTable make.IntegerVar: (table count). stomp _ table stepper. [stomp hasValue] whileTrue: [newTable at.IntegerVar: stomp index introduce: (table get.IntegerVar: stomp index). stomp step]. ^newTable" self passe! {IntegerTable} make.WordArray: wv {MuWordArray} "Make a copy of 'wv' as an IntegerTable. The IntegerTable starts out with the same state as 'wv', but unlike 'wv' is not obligated to maintain MuArray constraints." self passe.! !IntegerTable subclass: #MuArray instanceVariableNames: '' classVariableNames: 'MustBeContiguousDomainSignal {Signal smalltalk} ' poolDictionaries: '' category: 'Xanadu-Collection-Tables'! MuArray comment: 'The class XuArray is intended to model zero-based arrays with integer keys (indices). This makes them like the array primitive in C and C++. There is an additional constraint, which is they are to have simple domains. Therefore they should not be constructed with non-contiguous sections. This is not currently enforced. Given that it is enforced, an XuArray with count N would have as its domain exactly the integers from 0 to N-1. There is some controversy over whether XuArray should be a type and enforce this contraint (by BLASTing if an attempt is made to violate the constraint), or whether XuArray is just a specialized implementation for when an IntegerTable happens to meet this constraint; in which case it should "become" a more general implementation when an attempt is made to violate the constraint (see "Type Safe Become"). In the latter case, XuArray will probably be made a private class as well. Please give us your opinion. XuArray provides no additional protocol.'! (MuArray getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !MuArray methodsFor: 'accessing'! {Heaper} atInt: key {IntegerVar} store: value {Heaper} self subclassResponsibility! {CoordinateSpace} coordinateSpace ^ IntegerSpace make! {IntegerVar} count self subclassResponsibility.! {XnRegion} domain self subclassResponsibility.! {IntegerVar} highestIndex self subclassResponsibility! {Heaper} intFetch: key {IntegerVar} self subclassResponsibility! {BooleanVar} intWipe: anIdx {IntegerVar} self subclassResponsibility! {IntegerVar} lowestIndex self subclassResponsibility! {ScruTable} offsetSubTableBetween: startIndex {IntegerVar} with: stopIndex {IntegerVar} with: firstIndex {IntegerVar unused} "Return a table which contains the elements from start to stop, starting at firstIndex. Zero-based subclasses will blast if firstIndex is non-zero" ^ self subTableBetween: startIndex with: stopIndex! {ScruTable} subTable: region {XnRegion} self subclassResponsibility! {ScruTable} subTableBetween: startLoc {IntegerVar} with: endLoc {IntegerVar} self subclassResponsibility! {ScruTable} transformedBy: dsp {Dsp} (dsp inverse isEqual: dsp) ifTrue: [^self] ifFalse: [^MuArray offsetScruArray: self with: dsp]! ! !MuArray methodsFor: 'creation'! {ScruTable} copy self subclassResponsibility! {ScruTable} emptySize: size {IntegerVar} self subclassResponsibility! ! !MuArray methodsFor: 'testing'! {BooleanVar} includesIntKey: aKey {IntegerVar} ^aKey >= IntegerVar0 and: [aKey < self count]! {BooleanVar} isEmpty ^self count = IntegerVar0! ! !MuArray methodsFor: 'runs'! {XnRegion} runAtInt: key {IntegerVar} self subclassResponsibility! ! !MuArray methodsFor: 'enumerating'! {TableStepper} stepper: order {OrderSpec default: NULL} "Return a stepper on this table." self subclassResponsibility! {Heaper} theOne self count ~~ 1 ifTrue: [ Heaper BLAST: #NotOneElement ]. ^ self intFetch: IntegerVar0! ! !MuArray methodsFor: 'bulk operations'! {void} wipeAll: region {XnRegion} "I 'wipe' from myself all associations whose key is in 'region'. See MuTable::wipe" (region coordinateSpace isEqual: self coordinateSpace) ifFalse: [Heaper BLAST: #WrongCoordSpace]. self isEmpty ifTrue: [^VOID]. region isSimple ifFalse: [Heaper BLAST: #NotSimple]. ((region intersect: self domain) stepper: (IntegerSpace make getDescending)) forEach: [:p {IntegerPos} | self intWipe: p asIntegerVar]! ! !MuArray methodsFor: 'overload junk'! {Heaper} at: key {Position} store: value {Heaper} ^ self atInt: (key cast: IntegerPos) asIntegerVar store: value! {Heaper} fetch: key {Position} ^ self intFetch: ((key cast: IntegerPos) asIntegerVar)! {BooleanVar} includesKey: aKey {Position} ^self includesIntKey: ((aKey cast: IntegerPos) asIntegerVar)! {XnRegion} runAt: key {Position} ^self runAtInt: ((key quickCast: IntegerPos) asIntegerVar)! {BooleanVar} wipe: key {Position} ^ self intWipe: ((key cast: IntegerPos) asIntegerVar)! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MuArray class instanceVariableNames: ''! (MuArray getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !MuArray class methodsFor: 'creation'! {MuArray INLINE} array "A new empty XnArray" ^MuArray make.IntegerVar: 1! {MuArray} array: obj0 {Heaper} "A new XnArray initialized with a single element, 'obj0', stored at index 0." | table {MuArray} | table _ MuArray make.IntegerVar: 1. table atInt: IntegerVar0 store: obj0. ^table! {MuArray} array: obj0 {Heaper} with: obj1 {Heaper} "A new XnArray initialized with a two elements stored at indicies 0 and 1." | table {MuArray} | table _ MuArray make.IntegerVar: 2. table atInt: IntegerVar0 store: obj0. table atInt: 1 store: obj1. ^table! {MuArray} array: obj0 {Heaper} with: obj1 {Heaper} with: obj2 {Heaper} "A new XuArray initialized with a three elements stored at indicies 0, 1, and 2." | table {MuArray} | table _ MuArray make.IntegerVar: 3. table atInt: IntegerVar0 store: obj0. table atInt: 1 store: obj1. table atInt: 2 store: obj2. ^table! {MuArray} array: obj0 {Heaper} with: obj1 {Heaper} with: obj2 {Heaper} with: obj3 {Heaper} "A new XuArray initialized with a four elements stored at indicies 0 through 3." | table {MuArray} | table _ MuArray make.IntegerVar: 4. table atInt: IntegerVar0 store: obj0. table atInt: 1 store: obj1. table atInt: 2 store: obj2. table atInt: 3 store: obj3. ^table! {TableAccumulator} arrayAccumulator "Returns an Accumulator which will produce an XuArray of the elements accumulated into it in order of accumulation. See XuArray. Equivalent to 'tableAccumulator()'. Eventually either he or I should be declared obsolete." ^ ArrayAccumulator make: MuArray array! {TableAccumulator} arrayAccumulator: onArray {MuArray} "An accumulator which will accumulate by appending elements onto the end of 'onArray'. It is an error for anyone else to modify 'onArray' between creating this accumulator and accumulating into it. acc->value() will return 'onArray' itself." ^ArrayAccumulator make: onArray! make.IntegerVar: someSize {IntegerVar} "'someSize' is a hint about how big we should expect the array to need to grow." ^ActualArray create.IntegerVar: someSize! {ScruTable} offsetScruArray: array {MuArray} with: dsp {Dsp} "The resulting ScruTable is a view onto 'array'. It is a view in which each key is offset by 'dsp' from where it is in 'array'. By saying it is a view, we mean that as 'array' is modified, the view tracks the changes." ^OffsetScruArray make: array with: dsp! !MuArray subclass: #ActualArray instanceVariableNames: ' elements {PtrArray} tally {UInt32}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Tables'! (ActualArray getOrMakeCxxClassDescription) friends: '/* friends for class ActualArray */ friend class AscendingArrayStepper; friend SPTR(MuArray) MuArray::make(IntegerVar);'; attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !ActualArray methodsFor: 'testing'! {UInt32} fastHash ^tally + #cat.U.ActualArray hashForEqual! {BooleanVar} isEmpty ^tally == UInt32Zero! ! !ActualArray methodsFor: 'accessing'! {Heaper} atInt: index {IntegerVar} store: value {Heaper} "store the new value at the specified position. Note that this is an insertion iff the index is the same as the tally (that is, we're adding at the first empty position at the end of the array)." | reali {UInt32} old {Heaper} | value == NULL ifTrue: [Heaper BLAST: #NullInsertion]. (index < IntegerVar0 or: [index > tally]) ifTrue: [Heaper BLAST: #NotInDomain]. reali _ index DOTasLong. reali = tally ifTrue: [reali >= elements count ifTrue: [self enlarge]. tally _ tally + 1]. old _ elements fetch: reali. elements at: reali store: value. ^ old! {CoordinateSpace} coordinateSpace ^IntegerSpace make! {IntegerVar} count ^tally! {XnRegion} domain ^IntegerRegion make: IntegerVar0 with: tally! {IntegerVar} highestIndex ^ tally - 1! {Heaper} intFetch: index {IntegerVar} | idx {UInt32 register} | ((idx _ index DOTasLong) >= tally or: [index < IntegerVar0]) ifTrue: [^NULL] ifFalse: [^elements fetch: idx]! {BooleanVar} intWipe: index {IntegerVar} "Remove if the index is the last thing in the table. Blast if the index is some other element of the table. *Ignore* the request if it is any element not in the table." | reali {Int32 register} | reali _ index DOTasLong. reali == (tally - 1) ifTrue: [elements at: reali store: NULL. tally _ tally - 1. ^true]. "Now the error that results from a specialized implementation." (reali >= Int32Zero and: [reali < tally]) ifTrue: [Heaper BLAST: #IncompleteAbstraction]. ^false! {IntegerVar} lowestIndex ^ IntegerVar0! {ScruTable} offsetSubTableBetween: startIndex {IntegerVar} with: stopIndex {IntegerVar} with: firstIndex {IntegerVar} ^super offsetSubTableBetween: startIndex with: stopIndex with: firstIndex! {ScruTable} subTable: reg {XnRegion} ^self subTableBetween: (reg cast: IntegerRegion) start with: (reg cast: IntegerRegion) stop! {ScruTable} subTableBetween: start {IntegerVar} with: stop {IntegerVar} | begin {IntegerVar} end {IntegerVar} newArray {MuArray} reg {XnRegion} | start < IntegerVar0 ifTrue: [begin _ IntegerVar0] ifFalse: [begin _ start]. stop > self count ifTrue: [end _ self count] ifFalse: [end _ stop]. newArray _ MuArray make.IntegerVar: end - begin. reg _ IntegerRegion make: begin with: end. reg stepper forEach: [:pos {IntegerPos} | newArray atInt: (pos asIntegerVar - begin) introduce: (self intFetch: pos asIntegerVar)]. begin > IntegerVar0 ifTrue: [^OffsetScruArray make: newArray with: (IntegerMapping make: begin)] ifFalse: [^newArray]! ! !ActualArray methodsFor: 'creation'! {ScruTable} copy ^ ActualArray create: (elements copy cast: PtrArray) with: tally! {ScruTable} emptySize: size {IntegerVar unused} ^MuArray make.IntegerVar: (elements count)! ! !ActualArray methodsFor: 'private: creation'! create "The optional argument just hints at the number of elements to eventually be added. It makes no difference semantically." super create. elements _ PtrArray nulls: 4. tally _ UInt32Zero! create.IntegerVar: size {IntegerVar} "The optional argument just hints at the number of elements to eventually be added. It makes no difference semantically." | newSize {UInt32} | super create. size > 4 ifTrue: [newSize _ size DOTasLong] ifFalse: [newSize _ 4]. elements _ PtrArray nulls: newSize. tally _ UInt32Zero! create: newElems {PtrArray of: Heaper} with: newTally {UInt32} super create. elements _ newElems. tally _ newTally! {void} destruct elements destroy. elements _ NULL. super destruct! ! !ActualArray methodsFor: 'runs'! {XnRegion} runAtInt: anIdx {IntegerVar} | idx {IntegerVar} lastObj {Heaper} notDone {BooleanVar} | idx _ anIdx. (idx < IntegerVar0 or: [idx >= tally]) ifTrue: [ ^ IntegerRegion make ]. lastObj _ self intGet: idx. notDone _ true. [idx < tally and: [notDone]] whileTrue: [((self intGet: idx) isEqual: lastObj) ifTrue: [ idx _ idx + 1 ] ifFalse: [ notDone _ false ]]. ^ IntegerRegion make: anIdx with: idx! ! !ActualArray methodsFor: 'printing'! {void} printOn: aStream {ostream reference} aStream << self getCategory name. self printOnWithSimpleSyntax: aStream with: '[' with: ',' with: ']'! ! !ActualArray methodsFor: 'private: private'! {PtrArray} elementsArray "return the elements array for rapid processing" ^ elements! {UInt32} endOffset "return the size of the elements array for rapid processing" ^ tally-1! {void} enlarge "Enlarge the receiver to contain more slots filled with nil." | newElements {PtrArray of: Heaper} oldElements {PtrArray wimpy of: Heaper} | newElements _ (elements copyGrow: elements count) cast: PtrArray. "Just for the hell of it, I make this robust for asynchronous readers..." oldElements _ elements. elements _ newElements. oldElements destroy! {UInt32} maxElements "return the size of the elements array for rapid processing" ^ elements count! {UInt32} startOffset "return the size of the elements array for rapid processing" ^ UInt32Zero! ! !ActualArray methodsFor: 'smalltalk: private:'! {void} inspect ^InspectorView open: (IntegerTableInspector inspect: self)! {IntegerVar} search: item {Integer} | low {IntegerVar} high {IntegerVar} curr {IntegerVar} elem {IntegerVar} | self isEmpty ifTrue: [^ Integer IntegerVar: 0]. low _ self lowestIndex. high _ self highestIndex. [high >= low] whileTrue: [ curr _ (high + low // 2). (item > (elem _ (self fetch: curr))) ifTrue: [low _ curr + 1] ifFalse: [item == elem ifTrue: [low _ (high _ curr) + 1] ifFalse: [high _ curr - 1]]]. ^ high! ! !ActualArray methodsFor: 'enumerating'! {TableStepper} stepper: order {OrderSpec default: NULL} order == NULL ifTrue: [^AscendingArrayStepper make: self with: IntegerVar0 with: tally - 1] ifFalse: [(order followsInt: 1 with: IntegerVar0) ifTrue: [^AscendingArrayStepper make: self] ifFalse: [^IntegerTableStepper make: self with: order]]! ! !ActualArray methodsFor: 'overload junk'! {Heaper} at: key {Position} store: value {Heaper} ^ self atInt: (key cast: IntegerPos) asIntegerVar store: value! {Heaper} fetch: key {Position} ^ self intFetch: ((key cast: IntegerPos) asIntegerVar)! {XnRegion} runAt: anIdx {Position} ^ self runAtInt: ((anIdx cast: IntegerPos) asIntegerVar)! {BooleanVar} wipe: key {Position} ^ self intWipe: ((key cast: IntegerPos) asIntegerVar)! ! !ActualArray methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. elements _ receiver receiveHeaper. tally _ receiver receiveUInt32.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: elements. xmtr sendUInt32: tally.! !IntegerTable subclass: #OberIntegerTable instanceVariableNames: 'myNextCOW {COWIntegerTable NOCOPY | NULL}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Tables'! (OberIntegerTable getOrMakeCxxClassDescription) friends: '/* friends for class OberIntegerTable */ friend class ITAscendingStepper; friend class ITDescendingStepper; friend class ITGenericStepper; friend class COWIntegerTable;'; attributes: ((Set new) add: #DEFERRED; yourself)! !OberIntegerTable methodsFor: 'accessing'! {Heaper} atInt: key {IntegerVar} store: value {Heaper} self subclassResponsibility! {CoordinateSpace} coordinateSpace ^IntegerSpace make! {IntegerVar} count self subclassResponsibility! {XnRegion} domain self subclassResponsibility.! {IntegerVar} highestIndex "Given that the table is non-empty, 'intTab->highestIndex()' is equivalent to 'CAST(IntegerRegion,intTab->domain())->upperBound() -1'. The reason for the '-1' is that the 'upperBound' is an exclusive upper bound (see IntegerRegion::upperBound), whereas 'highestIndex' is the highest index which is in my domain. I need to here specify what 'highestIndex' does if I am empty." self subclassResponsibility! {Heaper} intFetch: key {IntegerVar} self subclassResponsibility! {BooleanVar} intWipe: anIdx {IntegerVar} self subclassResponsibility! {IntegerVar} lowestIndex "Given that the table is non-empty, 'intTab->lowestIndex()' is equivalent to 'CAST(IntegerRegion,intTab->domain())->lowerBound()'. 'lowestIndex' is the lowest index which is in my domain. I need to here specify what 'lowestIndex' does if I am empty." self subclassResponsibility! {ScruTable} subTable: reg {XnRegion} self subclassResponsibility! ! !OberIntegerTable methodsFor: 'creation'! {ScruTable} copy self subclassResponsibility! {ScruTable} emptySize: size {IntegerVar} self subclassResponsibility! {ScruTable} offsetSubTableBetween: startIndex {IntegerVar} with: stopIndex {IntegerVar} with: firstIndex {IntegerVar} "Return a table which contains the elements from start to stop, starting at firstIndex. Zero-based subclasses will blast if firstIndex is non-zero" self subclassResponsibility! {ScruTable} subTableBetween: startIndex {IntegerVar} with: stopIndex {IntegerVar} "Hack for C++ overloading problem" self subclassResponsibility! ! !OberIntegerTable methodsFor: 'runs'! {XnRegion} runAtInt: key {IntegerVar} self subclassResponsibility! ! !OberIntegerTable methodsFor: 'testing'! {BooleanVar} includesIntKey: aKey {IntegerVar} self subclassResponsibility! {BooleanVar} isEmpty self subclassResponsibility.! ! !OberIntegerTable methodsFor: 'enumerating'! {TableStepper} stepper: order {OrderSpec default: NULL} self subclassResponsibility! ! !OberIntegerTable methodsFor: 'private:'! {PtrArray} elementsArray "return the elements array for rapid processing" self subclassResponsibility! {UInt32} endOffset "return the size of the elements array for rapid processing" self subclassResponsibility! {IntegerVar} startIndex self subclassResponsibility! {UInt32} startOffset "return the size of the elements array for rapid processing" self subclassResponsibility! ! !OberIntegerTable methodsFor: 'protected: create'! create super create. myNextCOW _ NULL! ! !OberIntegerTable methodsFor: 'vulnerable: COW stuff'! {void} aboutToWrite | nextCOW {COWIntegerTable wimpy} | "make a copy of myself for all outstanding CopyOnWrites on me. pass that copy to each of the CopyOnWrite objects. One of the COWs gets to become my clone, and the rest point at it." nextCOW _ self getNextCOW. nextCOW ~~ NULL ifTrue: [| cowP {COWIntegerTable wimpy} | self becomeCloneOnWrite: nextCOW. cowP _ nextCOW getNextCOW. [cowP ~~ NULL] whileTrue: [cowP setMuTable: nextCOW. cowP _ cowP getNextCOW]. self setNextCOW: NULL]! {void} becomeCloneOnWrite: where {Heaper unused} self subclassResponsibility! {COWIntegerTable wimpy} getNextCOW ^ myNextCOW! {void} setNextCOW: table {COWIntegerTable} myNextCOW _ table! ! !OberIntegerTable methodsFor: 'overload junk'! {Heaper} at: key {Position} store: value {Heaper} ^ self atInt: (key cast: IntegerPos) asIntegerVar store: value! {Heaper} fetch: key {Position} ^ self intFetch: (key cast: IntegerPos) asIntegerVar! {BooleanVar} includesKey: aKey {Position} ^ self includesIntKey: (aKey cast: IntegerPos) asIntegerVar! {XnRegion} runAt: key {Position} ^ self runAtInt: (key cast: IntegerPos) asIntegerVar! {BooleanVar} wipe: key {Position} ^ self intWipe: (key cast: IntegerPos) asIntegerVar! !OberIntegerTable subclass: #ActualIntegerTable instanceVariableNames: ' elements {PtrArray} start {IntegerVar} elemCount {UInt32} firstElem {UInt32} lastElem {UInt32} tally {UInt32} domainIsSimple {BooleanVar}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Tables'! ActualIntegerTable comment: 'The IntegerTable class is intended to provide an integer indexed table which is not constrained to be zero based.'! (ActualIntegerTable getOrMakeCxxClassDescription) friends: '/* friends for class ActualIntegerTable */ friend class ITAscendingStepper; friend class ITDescendingStepper; friend class ITGenericStepper;'; attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !ActualIntegerTable methodsFor: 'testing'! {UInt32} fastHash ^(((start DOTasLong bitXor: firstElem) bitXor: tally) bitXor: lastElem) + #cat.U.ActualIntegerTable hashForEqual! {BooleanVar} includesIntKey: aKey {IntegerVar} (aKey < self lowestIndex or: [aKey > self highestIndex]) ifTrue: [^false] ifFalse: [domainIsSimple ifTrue: [^true] ifFalse: [^(elements fetch: aKey DOTasLong - start DOTasLong) ~~ NULL]]! {BooleanVar} isEmpty ^tally == UInt32Zero! ! !ActualIntegerTable methodsFor: 'accessing'! {Heaper} atInt: index {IntegerVar} store: value {Heaper} | reali {Int32} old {Heaper} | value == NULL ifTrue: [Heaper BLAST: #NullInsertion]. tally == UInt32Zero ifTrue: [start _ index]. index - start >= elemCount ifTrue: [self enlargeAfter: index] ifFalse: [index < start ifTrue: [self enlargeBefore: index]]. reali _ (index - start) DOTasLong. (old _ elements fetch: reali) == NULL ifTrue: [tally _ tally + 1]. reali < firstElem ifTrue: [ (firstElem - reali) > 1 ifTrue: [domainIsSimple _ false]. firstElem _ reali]. reali > lastElem ifTrue: [ (reali - lastElem) > 1 ifTrue: [domainIsSimple _ false]. lastElem _ reali]. elements at: reali store: value. ^ old! {CoordinateSpace} coordinateSpace ^IntegerSpace make! {IntegerVar} count ^tally! {XnRegion} domain "" "The domainIsSimple flag is used as an optimization in this method. When it is True, I stop looking after the first simple domain I find. Therefore, when True, it MUST BE CORRECT. When it is False, I do a complete search, and set the flag if the domain turns out to be simple." | newReg {XnRegion} | self isEmpty ifTrue: [^IntegerRegion make] ifFalse: [domainIsSimple ifTrue: [^IntegerRegion make: self lowestIndex with: self highestIndex + 1] ifFalse: [newReg _ self generateDomain. newReg isSimple ifTrue: [domainIsSimple _ true]. ^newReg]]! {IntegerVar} highestIndex tally == UInt32Zero ifTrue: [^start]. ^ start + lastElem! {Heaper} intFetch: index {IntegerVar} | idx {UInt32}| ((idx _ (index-start) DOTasLong) >= elemCount or: [index < start]) ifTrue: [^NULL] ifFalse: [^elements fetch: idx]! {BooleanVar} intWipe: index {IntegerVar} | reali {UInt32} wiped {BooleanVar} | wiped _ false. reali _ (index - start) DOTasLong. (reali > lastElem or: [reali < firstElem]) ifFalse: [(elements fetch: reali) ~~ NULL ifTrue: [tally _ tally - 1. wiped _ true]. elements at: reali store: NULL. reali == firstElem ifTrue: [firstElem _ self firstElemAfter: reali] ifFalse: [reali == lastElem ifTrue: [lastElem _ self lastElemBefore: reali] ifFalse: [domainIsSimple _ false]]]. ^ wiped! {IntegerVar} lowestIndex tally == UInt32Zero ifTrue: [^start]. ^ start + firstElem! ! !ActualIntegerTable methodsFor: 'creation'! {ScruTable} copy ^ ActualIntegerTable create: (elements copy cast: PtrArray) with: start with: elemCount with: firstElem with: lastElem with: tally with: domainIsSimple! create "The optional argument just hints at the number of elements to eventually be added. It makes no difference semantically." super create. elements _ PtrArray nulls: 8. start _ IntegerVar0. firstElem _ 7. lastElem _ UInt32Zero. elemCount _ 8. tally _ UInt32Zero. domainIsSimple _ true.! create.IntegerVar: size {IntegerVar} "The optional argument just hints at the number of elements to eventually be added. It makes no difference semantically." super create. size > IntegerVar0 ifTrue: [elemCount _ size DOTasLong] ifFalse: [elemCount _ 4]. elements _ PtrArray nulls: elemCount. start _ IntegerVar0. tally _ UInt32Zero. firstElem _ elemCount - 1. lastElem _ UInt32Zero. domainIsSimple _ true.! create: begin {IntegerVar} with: end {IntegerVar} "Hint at the domain to be accessed (inclusive, exclusive)." super create. start _ begin. elemCount _ (end - start) DOTasLong. elemCount < 4 ifTrue: [elemCount _ 4]. elements _ PtrArray nulls: elemCount. firstElem _ elemCount - 1. lastElem _ UInt32Zero. tally _ UInt32Zero. domainIsSimple _ true! create: array {PtrArray} with: begin {IntegerVar} with: count {UInt32} with: first {UInt32} with: last {UInt32} with: aTally {UInt32} with: simple {BooleanVar} super create. elements := array. start := begin. elemCount := count. firstElem := first. lastElem := last. tally := aTally. domainIsSimple := simple! {void} destroy self getNextCOW == NULL ifTrue: [super destroy]! {ScruTable} emptySize: size {IntegerVar unused} ^IntegerTable make.IntegerVar: (self lowestIndex) with: (self highestIndex + 1)! {ScruTable} offsetSubTableBetween: startIndex {IntegerVar} with: stopIndex {IntegerVar} with: firstIndex {IntegerVar} "Copy the given range into a new IntegerTable. The range is startIndex (inclusive) to stopIndex (exclusive) The first element in the sub table will be at firstIndex" | table {IntegerTable} theEnd {IntegerVar} | theEnd _ firstIndex + stopIndex - startIndex - 1. table _ IntegerTable make.IntegerVar: firstIndex with: theEnd. firstIndex to: theEnd do: [:i {IntegerVar} | | val {Heaper wimpy} | val _ self intFetch: i + startIndex - firstIndex. val == NULL ifFalse: [table atInt: i introduce: val]]. ^table! {ScruTable} subTable: reg {XnRegion} | subRegion {IntegerRegion} | subRegion _ (reg intersect: self domain asSimpleRegion) cast: IntegerRegion. subRegion isEmpty ifTrue: [^ self emptySize: (self count max: 1)]. ^self subTableBetween: subRegion start with: subRegion stop! {ScruTable} subTableBetween: startIndex {IntegerVar} with: stopIndex {IntegerVar} "Hack for C++ overloading problem" ^self offsetSubTableBetween: startIndex with: stopIndex with: startIndex! ! !ActualIntegerTable methodsFor: 'runs'! {XnRegion} runAtInt: anIdx {IntegerVar} | idx {UInt32} lastObj {Heaper} notDone {BooleanVar} | idx _ (anIdx - start) DOTasLong. tally == UInt32Zero ifTrue: [^ IntegerRegion make]. (idx < firstElem or: [idx > lastElem]) ifTrue: [^IntegerRegion make: anIdx with: anIdx]. notDone _ true. (lastObj _ elements fetch: idx) == NULL ifTrue: [[idx <= lastElem and: [notDone]] whileTrue: [(elements fetch: idx) == NULL ifTrue: [idx _ idx + 1] ifFalse: [notDone _ false]]] ifFalse: [[idx <= lastElem and: [notDone]] whileTrue: [(elements fetch: idx) ~~ NULL ifTrue: [((elements fetch: idx) isEqual: lastObj) ifTrue: [idx _ idx + 1] ifFalse: [notDone _ false]] ifFalse: [notDone _ false]]]. ^IntegerRegion make: anIdx with: (start + idx)! ! !ActualIntegerTable methodsFor: 'printing'! {void} printOn: aStream {ostream reference} aStream << self getCategory name. self printOnWithSimpleSyntax: aStream with: '[' with: ',' with: ']'! ! !ActualIntegerTable methodsFor: 'enumerating'! {TableStepper} stepper: order {OrderSpec default: NULL} "ignore order spec for now" "Note that this method depends on the ITAscendingStepper NOT copying the table." order == NULL ifTrue: [tally == UInt32Zero ifTrue: [^IntegerTableStepper make: self with: start with: start] ifFalse: [^ITAscendingStepper create: (self copy cast: OberIntegerTable) with: start + firstElem "self lowestIndex" with: start + lastElem "self highestIndex"]] ifFalse: [^IntegerTableStepper make: self with: order]! {Heaper} theOne self count ~~ 1 ifTrue: [ Heaper BLAST: #NotOneElement ]. ^ self intFetch: self lowestIndex! ! !ActualIntegerTable methodsFor: 'private:'! {IntegerRegion} contigDomainStarting: anIdx {UInt32} | begin {UInt32} tIdx {UInt32} | tIdx _ begin _ anIdx. [tIdx <= lastElem and: [(elements fetch: tIdx) ~~ NULL]] whileTrue: [tIdx _ tIdx + 1]. tIdx > begin ifTrue: [^IntegerRegion make: start + begin with: start + tIdx] ifFalse: [^IntegerRegion make: anIdx with: anIdx]! {PtrArray} elementsArray "return the elements array for rapid processing" ^ elements! {UInt32} endOffset "return the size of the elements array for rapid processing" ^ lastElem! {void} enlargeAfter: toMinimum {IntegerVar} "Enlarge the receiver to contain more slots filled with nil." | newElements{PtrArray} oldElements {PtrArray wimpy} tmp {UInt32} newSize {UInt32} | newSize _ elemCount * 2. newSize < 4 ifTrue: [newSize _ 4]. (newSize < (tmp _ (toMinimum - start) DOTasLong + 1)) ifTrue: [newSize _ tmp]. newElements _ PtrArray nulls: newSize. UInt32Zero almostTo: elemCount do: [:i {UInt32} | newElements at: i store: (elements fetch: i)]. "Just for the hell of it, I make this robust for asynchronous readers..." oldElements _ elements. elements _ newElements. oldElements destroy. elemCount _ newSize. tally == UInt32Zero ifTrue: [firstElem _ elements count - 1]! {void} enlargeBefore: toMinimum {IntegerVar} "Enlarge the receiver to contain more slots filled with nil." | newSize {UInt32} newElements {PtrArray} oldElements {PtrArray wimpy} offset {UInt32} tmp {UInt32} stop {IntegerVar} | stop _ start + elemCount. newSize _ elemCount * 2. newSize < 4 ifTrue: [newSize _ 4]. newSize < (tmp _ (stop - toMinimum) DOTasLong + 1) ifTrue: [newSize _ tmp]. newElements _ PtrArray nulls: newSize. offset _ newSize - elemCount. UInt32Zero almostTo: elemCount do: [:i {UInt32} | newElements at: i + offset store: (elements fetch: i)]. oldElements _ elements. elements _ newElements. oldElements destroy. start _ stop - newSize. firstElem _ firstElem + offset. lastElem _ lastElem + offset. elemCount _ newSize! {UInt32} firstElemAfter: index {UInt32} "This method returns the first table entry that is not NULL after index." | idx {UInt32} | (tally == UInt32Zero) ifTrue: [^elemCount]. idx _ index + 1. [(idx < lastElem) and: [(elements fetch: idx) == NULL]] whileTrue: [idx _ idx + 1]. ^ idx! {IntegerRegion} generateDomain | begin {UInt32} resReg {IntegerRegion} nextReg {IntegerRegion} | resReg _ IntegerRegion make. tally == UInt32Zero ifTrue: [^resReg]. begin _ firstElem. [begin <= lastElem] whileTrue: [nextReg _ self contigDomainStarting: begin. nextReg isEmpty ifTrue: [nextReg _ self nullDomainStarting: begin] ifFalse: [resReg _ (resReg unionWith: nextReg) cast: IntegerRegion]. begin _ (nextReg stop - start) DOTasLong]. ^resReg! {UInt32} lastElemBefore: index {UInt32} "This method returns the first table entry that is not NULL after index." | idx {UInt32} | (tally == UInt32Zero) ifTrue: [^UInt32Zero]. idx _ index - 1. [(idx > firstElem) and: [(elements fetch: idx) == NULL]] whileTrue: [idx _ idx - 1]. ^ idx! {UInt32} maxElements "return the size of the elements array for rapid processing" ^ elemCount! {IntegerRegion} nullDomainStarting: anIdx {UInt32} | begin {UInt32} tIdx {UInt32} | tIdx _ begin _ anIdx. [tIdx <= lastElem and: [(elements fetch: tIdx) == NULL]] whileTrue: [tIdx _ tIdx + 1]. tIdx > begin ifTrue: [^IntegerRegion make: start + begin with: start + tIdx] ifFalse: [^IntegerRegion make: anIdx with: anIdx]! {IntegerVar} startIndex "return the size of the elements array for rapid processing" ^ start! {UInt32} startOffset "return the size of the elements array for rapid processing" ^ firstElem! ! !ActualIntegerTable methodsFor: 'smalltalk: private:'! fixup super fixup. [((elements fetch: lastElem) == NULL) and: [lastElem > 0]] whileTrue: [ Transcript show: 'd'. lastElem _ lastElem - 1]! {void} inspect ^InspectorView open: (IntegerTableInspector inspect: self)! ! !ActualIntegerTable methodsFor: 'protected: destruct'! {void} destruct elements destroy. elements _ NULL. super destruct! ! !ActualIntegerTable methodsFor: 'protected: COW stuff'! {void} becomeCloneOnWrite: where {Heaper} | tmp {IntegerTable} source {TableStepper} | tmp _ (ActualIntegerTable new.Become: where) create: start with: (start + lastElem). tally == UInt32Zero ifTrue: [^ VOID]. source _ ITAscendingStepper create: self with: start + firstElem with: start + lastElem. source forEach: [ :tableElem {Heaper} | tmp at: source position store: tableElem].! ! !ActualIntegerTable methodsFor: 'overload junk'! {Heaper} at: key {Position} store: value {Heaper} ^ self atInt: (key cast: IntegerPos) asIntegerVar store: value! {Heaper} fetch: key {Position} ^ self intFetch: ((key cast: IntegerPos) asIntegerVar)! {BooleanVar} includesKey: aKey {Position} ^ self includesIntKey: ((aKey cast: IntegerPos) asIntegerVar)! {XnRegion} runAt: anIdx {Position} ^ self runAtInt: ((anIdx cast: IntegerPos) asIntegerVar)! {BooleanVar} wipe: key {Position} ^ self intWipe: ((key cast: IntegerPos) asIntegerVar)! ! !ActualIntegerTable methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. elements _ receiver receiveHeaper. start _ receiver receiveIntegerVar. elemCount _ receiver receiveUInt32. firstElem _ receiver receiveUInt32. lastElem _ receiver receiveUInt32. tally _ receiver receiveUInt32. domainIsSimple _ receiver receiveBooleanVar.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: elements. xmtr sendIntegerVar: start. xmtr sendUInt32: elemCount. xmtr sendUInt32: firstElem. xmtr sendUInt32: lastElem. xmtr sendUInt32: tally. xmtr sendBooleanVar: domainIsSimple.! !OberIntegerTable subclass: #COWIntegerTable instanceVariableNames: ' myPrev {OberIntegerTable NOCOPY | NULL} myTable {OberIntegerTable}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Tables'! (COWIntegerTable getOrMakeCxxClassDescription) attributes: ((Set new) add: #(MAY.BECOME ActualIntegerTable ); add: #CONCRETE; add: #COPY; yourself)! !COWIntegerTable methodsFor: 'accessing'! {Heaper} atInt: aKey {IntegerVar} store: anObject {Heaper} self aboutToWrite. ^ self atInt: aKey store: anObject! {CoordinateSpace} coordinateSpace ^ myTable coordinateSpace! {IntegerVar} count ^ myTable count! {XnRegion} domain ^ myTable domain! {IntegerVar} highestIndex ^ myTable highestIndex! {Heaper} intFetch: key {IntegerVar} ^myTable intFetch: key! {BooleanVar} intWipe: anIdx {IntegerVar} self aboutToWrite. ^self intWipe: anIdx! {IntegerVar} lowestIndex ^ myTable lowestIndex! {ScruTable} subTable: reg {XnRegion} ^ myTable subTable: reg! ! !COWIntegerTable methodsFor: 'creation'! {ScruTable} copy ^ myTable copy! create: table {OberIntegerTable} super create. myPrev _ table. self setNextCOW: table getNextCOW. table setNextCOW: self. myTable _ table! {void} destroy "only recover these during GC. otherwise crashes occur"! {ScruTable} emptySize: size {IntegerVar} ^ myTable emptySize: size! {ScruTable} offsetSubTableBetween: startIndex {IntegerVar} with: stopIndex {IntegerVar} with: firstIndex {IntegerVar} ^myTable offsetSubTableBetween: startIndex with: stopIndex with: firstIndex! {ScruTable} subTableBetween: startIndex {IntegerVar} with: stopIndex {IntegerVar} ^myTable subTableBetween: startIndex with: stopIndex! ! !COWIntegerTable methodsFor: 'runs'! {XnRegion} runAtInt: index {IntegerVar} ^myTable runAtInt: index! ! !COWIntegerTable methodsFor: 'testing'! {BooleanVar} includesIntKey: aKey {IntegerVar} ^myTable includesIntKey: aKey! {BooleanVar} isEmpty ^ myTable isEmpty! ! !COWIntegerTable methodsFor: 'enumerating'! {TableStepper} stepper: order {OrderSpec default: NULL} ^ myTable stepper: order! ! !COWIntegerTable methodsFor: 'COW stuff'! {OberIntegerTable wimpy} getPrev (myPrev ~~ NULL) assert: 'NULL in getPrev'. ^ myPrev! {void} setMuTable: table {OberIntegerTable} myTable _ table! {void} setPrev: set {OberIntegerTable} myPrev _ set! ! !COWIntegerTable methodsFor: 'private:'! {PtrArray} elementsArray "return the elements array for rapid processing" ^ myTable elementsArray! {UInt32} endOffset "return the size of the elements array for rapid processing" ^ myTable endOffset! {IntegerVar} startIndex ^ myTable startIndex! {UInt32} startOffset "return the size of the elements array for rapid processing" ^ myTable startOffset! ! !COWIntegerTable methodsFor: 'protected: COW stuff'! {void} aboutToWrite | prev {OberIntegerTable wimpy} next {COWIntegerTable wimpy} | "become a copy of myMuTable and remove myself from all CopyOnWrite dependendents lists. The caller's self/this pointer will point to the becomed object after this returns. This makes all my caller's look like they are recursive, but they aren't." prev _ self getPrev. next _ self getNextCOW. next ~~ NULL ifTrue: [ next setPrev: prev ]. prev setNextCOW: next. myTable becomeCloneOnWrite: self.! {void} becomeCloneOnWrite: where {Heaper unused} self shouldNotImplement.! ! !COWIntegerTable methodsFor: 'overload junk'! {Heaper} at: key {Position} store: value {Heaper} ^ self atInt: (key cast: IntegerPos) asIntegerVar store: value! {Heaper} fetch: key {Position} ^ self intFetch: (key cast: IntegerPos) asIntegerVar! {BooleanVar} includesKey: aKey {Position} ^ self includesIntKey: ((aKey cast: IntegerPos) asIntegerVar)! {XnRegion} runAt: key {Position} ^ self runAtInt: ((key cast: IntegerPos) asIntegerVar)! {BooleanVar} wipe: key {Position} ^ self intWipe: (key cast: IntegerPos) asIntegerVar! ! !COWIntegerTable methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myTable _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myTable.! !ScruTable subclass: #OffsetScruArray instanceVariableNames: ' myArray {MuArray} myDsp {Dsp}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Tables'! (OffsetScruArray getOrMakeCxxClassDescription) friends: 'friend class XuArray;'; attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; add: #COPY; yourself)! !OffsetScruArray methodsFor: 'accessing'! {CoordinateSpace} coordinateSpace ^myArray coordinateSpace! {IntegerVar} count ^myArray count! {XnRegion} domain ^myDsp ofAll: myArray domain! {Heaper} fetch: anIndex {Position} ^myArray intFetch: (myDsp inverseOfInt: (anIndex cast: IntegerPos) asIntegerVar)! {Heaper} intFetch: idx {IntegerVar} ^myArray intFetch: (myDsp inverseOfInt: idx)! {ScruTable} subTable: encl {XnRegion} | lr {IntegerRegion} | lr _ encl cast: IntegerRegion. ^myArray subTableBetween: (myDsp inverseOfInt: lr start) with: (myDsp inverseOfInt: lr stop)! {ScruTable} subTableBetween: startLoc {IntegerVar} with: endLoc {IntegerVar} ^OffsetScruArray make: ((myArray subTableBetween: (myDsp inverseOfInt: startLoc) with: (myDsp inverseOfInt: endLoc)) cast: MuArray) with: myDsp! {ScruTable} transformedBy: dsp {Dsp} (myDsp inverse isEqual: dsp) ifTrue: [^myArray] ifFalse: [^OffsetScruArray make: myArray with: (dsp compose: myDsp)]! ! !OffsetScruArray methodsFor: 'runs'! {XnRegion} runAt: key {Position} ^self runAtInt: (key quickCast: IntegerPos) asIntegerVar! {XnRegion} runAtInt: anIdx {IntegerVar} ^myDsp ofAll: (myArray runAtInt: (myDsp inverseOfInt: anIdx))! ! !OffsetScruArray methodsFor: 'testing'! {UInt32} actualHashForEqual ^#cat.U.OffsetScruArray hashForEqual + myArray hashForEqual + myDsp hashForEqual! {BooleanVar} includesIntKey: aKey {IntegerVar} ^myArray includesIntKey: (myDsp inverseOfInt: aKey)! {BooleanVar} includesKey: aKey {Position} ^ self includesIntKey: ((aKey cast: IntegerPos) asIntegerVar)! {BooleanVar} isEmpty ^myArray isEmpty! {BooleanVar} isEqual: other {Heaper} other cast: OffsetScruArray into: [:osa | ^(osa innerArray isEqual: myArray) and: [osa innerArray isEqual: myArray]] others: [^false]. ^false "fodder"! ! !OffsetScruArray methodsFor: 'printing'! {void} printOn: aStream {ostream reference} aStream << self getCategory name << '(' << myDsp << ', ' << myArray << ')'! ! !OffsetScruArray methodsFor: 'protected: create'! create: array {MuArray} with: dsp {Dsp} super create. myArray _ array. myDsp _ dsp! ! !OffsetScruArray methodsFor: 'creation'! {ScruTable} copy ^ OffsetScruArray make: (myArray copy cast: MuArray) with: myDsp! {ScruTable} empty ^ myArray emptySize: 4! {ScruTable} emptySize: size {IntegerVar} ^ myArray emptySize: size! ! !OffsetScruArray methodsFor: 'conversion'! {ImmuTable} asImmuTable ^ ImmuTable offsetImmuTable: myArray asImmuTable with: myDsp! {MuTable} asMuTable | newArray {MuTable} s {TableStepper} | newArray _ (myArray emptySize: myArray count) asMuTable. (s _ myArray stepper) forEach: [ :e {Heaper} | newArray atInt: (myDsp ofInt: s index) store: e]. ^ newArray! ! !OffsetScruArray methodsFor: 'smalltalk: private'! {TableStepper} stepper ^ OffsetArrayStepper make: (myArray stepper) with: myDsp! ! !OffsetScruArray methodsFor: 'enumerating'! {TableStepper} stepper: order {OrderSpec default: NULL} ^OffsetArrayStepper make: (myArray stepper: order) with: myDsp! ! !OffsetScruArray methodsFor: 'private: private'! {MuArray} innerArray ^myArray! {Dsp} innerDsp ^myDsp! ! !OffsetScruArray methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myArray _ receiver receiveHeaper. myDsp _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myArray. xmtr sendHeaper: myDsp.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! OffsetScruArray class instanceVariableNames: ''! (OffsetScruArray getOrMakeCxxClassDescription) friends: 'friend class XuArray;'; attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; add: #COPY; yourself)! !OffsetScruArray class methodsFor: 'create'! {ScruTable} make: array {MuArray} with: dsp {Dsp} ^ self create: array with: dsp! !ScruTable subclass: #OffsetScruTable instanceVariableNames: ' myTable {ScruTable} myDsp {Dsp}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Tables'! (OffsetScruTable getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !OffsetScruTable methodsFor: 'accessing'! {CoordinateSpace} coordinateSpace ^myTable coordinateSpace! {IntegerVar} count ^myTable count! {XnRegion} domain ^myDsp ofAll: myTable domain! {Heaper} fetch: anIndex {Position} ^myTable intFetch: (myDsp inverseOfInt: (anIndex cast: IntegerPos) asIntegerVar)! {Heaper} intFetch: idx {IntegerVar} ^myTable intFetch: (myDsp inverseOfInt: idx)! {ScruTable} subTable: encl {XnRegion} ^OffsetScruTable create: (myTable subTable: (myDsp inverseOfAll: encl)) with: myDsp.! {ScruTable} transformedBy: dsp {Dsp} (myDsp inverse isEqual: dsp) ifTrue: [^myTable] ifFalse: [^OffsetScruTable create: myTable with: (dsp compose: myDsp)]! ! !OffsetScruTable methodsFor: 'runs'! {XnRegion} runAt: key {Position} (self includesKey: (myDsp inverseOf: key)) ifTrue: [^ key asRegion] ifFalse: [^ myTable coordinateSpace emptyRegion]! {XnRegion} runAtInt: anIdx {IntegerVar} ^myDsp ofAll: (myTable runAtInt: (myDsp inverseOfInt: anIdx))! ! !OffsetScruTable methodsFor: 'testing'! {UInt32} actualHashForEqual ^#cat.U.OffsetScruTable hashForEqual + myTable hashForEqual + myDsp hashForEqual! {BooleanVar} includesIntKey: aKey {IntegerVar} ^myTable includesIntKey: (myDsp inverseOfInt: aKey)! {BooleanVar} includesKey: aKey {Position} ^ myTable includesKey: (myDsp inverseOf: aKey)! {BooleanVar} isEmpty ^myTable isEmpty! {BooleanVar} isEqual: other {Heaper} other cast: OffsetScruTable into: [:ost | ^(ost innerTable isEqual: myTable) and: [ost innerTable isEqual: myTable]] others: [^false]. ^ false "compiler fodder"! ! !OffsetScruTable methodsFor: 'printing'! {void} printOn: aStream {ostream reference} aStream << self getCategory name << '(' << myDsp << ', ' << myTable << ')'! ! !OffsetScruTable methodsFor: 'creation'! {ScruTable} copy ^ OffsetScruTable create: myTable copy with: myDsp! create: table {ScruTable} with: dsp {Dsp} super create. myTable _ table. myDsp _ dsp! {ScruTable} emptySize: size {IntegerVar} ^ myTable emptySize: size! ! !OffsetScruTable methodsFor: 'conversion'! {ImmuTable} asImmuTable ^ OffsetImmuTable create: myTable asImmuTable with: myDsp! {MuTable} asMuTable | newTab {MuTable} s {TableStepper} | newTab _ (myTable emptySize: myTable count) asMuTable. (s _ myTable stepper) forEach: [ :e {Heaper} | newTab at: (myDsp of: s position) store: e]. ^ newTab! ! !OffsetScruTable methodsFor: 'smalltalk: private'! {TableStepper} stepper ^ OffsetScruTableStepper create.Stepper: (myTable stepper) with: myDsp! ! !OffsetScruTable methodsFor: 'enumerating'! {TableStepper} stepper: order {OrderSpec default: NULL} ^OffsetScruTableStepper create.Stepper: (myTable stepper: order) with: myDsp! ! !OffsetScruTable methodsFor: 'private:'! {Dsp} innerDsp ^myDsp! {ScruTable} innerTable ^myTable! !Heaper subclass: #ServerChunk instanceVariableNames: ' myFluidSpace {char star} myEndingState {Int32}' classVariableNames: 'SecretEmulsion {Emulsion} ' poolDictionaries: '' category: 'Xanadu-rcmain'! ServerChunk comment: 'This is the superclass for all the Chunks. Chunks represent pieces of the server that run for a while, then return control. Subclasses include Listeners that wait for input. When manually destroyed, this class flags itself for cleanup after any current request is finished--myEnding state is alive, alive in request, destruction requested, and ready for destruction.'! (ServerChunk getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #EQ; yourself)! !ServerChunk methodsFor: 'protected: accessing'! {BooleanVar} destroyOKIfRequested (myEndingState == ServerChunk inRequestFlag or: [myEndingState == ServerChunk destroyRequestedFlag]) ifTrue: [ myEndingState := ServerChunk destroyReadyFlag. ^ true] ifFalse: [^false]! {BooleanVar} destroyPending ^ myEndingState == ServerChunk destroyRequestedFlag.! {void} inRequest myEndingState := ServerChunk inRequestFlag.! {void} notInRequest myEndingState == ServerChunk destroyRequestedFlag ifTrue: [myEndingState := ServerChunk destroyReadyFlag] ifFalse: [myEndingState == ServerChunk inRequestFlag ifTrue: [myEndingState := ServerChunk aliveFlag]]! ! !ServerChunk methodsFor: 'testing'! {BooleanVar} shouldDestroy "Returns TRUE if this chunk wants to be deleted after deregistration." ^ myEndingState == ServerChunk destroyReadyFlag! ! !ServerChunk methodsFor: 'accessing'! {BooleanVar} execute "Attempt to execute another chunk. Return whether there is more to be done." self subclassResponsibility.! {char star} fluidSpace ^myFluidSpace.! {char star} fluidSpace: aFluidSpace {char star} ^myFluidSpace _ aFluidSpace.! ! !ServerChunk methodsFor: 'protected: destruct'! {void} destruct "ServerChunks are destroyed explicitly in the server loop." | saveChunk {ServerChunk} | (myFluidSpace ~~ NULL) ifTrue: [ saveChunk _ CurrentChunk. CurrentChunk _ self. ServerChunk emulsion destructAll. CurrentChunk _ saveChunk.]. ServerLoop removeChunk: self. ChunkCleaner beClean. super destruct.! ! !ServerChunk methodsFor: 'creation'! create super create. myFluidSpace _ NULL. myEndingState := Int32Zero.! {void} destroy (myEndingState == ServerChunk aliveFlag or: [myEndingState == ServerChunk destroyReadyFlag]) ifTrue: [super destroy] ifFalse: [ myEndingState == ServerChunk destroyRequestedFlag ifTrue: [Heaper BLAST: #AlreadyDestroyed]. myEndingState := ServerChunk destroyRequestedFlag]! ! !ServerChunk methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ServerChunk class instanceVariableNames: ''! (ServerChunk getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #EQ; yourself)! !ServerChunk class methodsFor: 'accessing'! {Emulsion} emulsion [SecretEmulsion == nil ifTrue: [SecretEmulsion _ NULL]] smalltalkOnly. (SecretEmulsion == NULL) ifTrue: [ SecretEmulsion _ ListenerEmulsion new create]. ^SecretEmulsion.! ! !ServerChunk class methodsFor: 'smalltalk: init'! cleanupGarbage SecretEmulsion _ NULL! linkTimeNonInherited ServerChunk defineGlobal: #CurrentChunk with: NULL. SecretEmulsion _ NULL.! ! !ServerChunk class methodsFor: 'protected: accessing'! {Int32 INLINE} aliveFlag ^ Int32Zero! {Int32 INLINE} destroyReadyFlag ^ 3! {Int32 INLINE} destroyRequestedFlag ^ 2! {Int32 INLINE} inRequestFlag ^ 1! !ServerChunk subclass: #ExecutePromiseFile instanceVariableNames: ' myReadName {char star} myWriteName {char star} myManager {PromiseManager NOCOPY} myConnection {Connection NOCOPY}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! ExecutePromiseFile comment: 'Read client requests from one files and write the results to another file.'! (ExecutePromiseFile getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); yourself)! !ExecutePromiseFile methodsFor: 'operate'! {BooleanVar} execute "Execute the action defined by this thunk." myManager handleRequest. self thingToDo. "Check whether the read file is Empty." ^true! ! !ExecutePromiseFile methodsFor: 'hooks:'! {void RECEIVE.HOOK} restartPromises: rcvr {Rcvr unused} | readStream {XnReadStream} writeStream {XnWriteStream} | readStream _ XnReadFile make: myReadName. writeStream _ XnWriteFile make: myWriteName. myManager _ PromiseManager make: (PairPortal make: readStream with: writeStream). myConnection _ Connection make: FeServer. self thingToDo. "This should be unnecessary."! ! !ExecutePromiseFile methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myReadName _ receiver receiveString. myWriteName _ receiver receiveString. self restartPromises: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendString: myReadName. xmtr sendString: myWriteName.! !ServerChunk subclass: #FDListener instanceVariableNames: 'myFD {int NOCOPY}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-rcmain'! FDListener comment: 'This is the superclass for Listeners that use Berkeley UNIX sockets.'! (FDListener getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #EQ; yourself)! !FDListener methodsFor: 'accessing'! {int} descriptor ^myFD.! {BooleanVar} execute "Attempt to execute another chunk. Return whether there is more to be done." self subclassResponsibility.! {BooleanVar} shouldBeReady "There should be data waiting on this FD. Return TRUE if I am still in a reasonable state to continue, FALSE if not (in which case the Listener will be destroyed by the caller)" self subclassResponsibility.! ! !FDListener methodsFor: 'creation'! create super create. [myFD _ Int32Zero] smalltalkOnly. 'myFD = (int) Int32Zero;' translateOnly.! {void} destruct [myFD close] smalltalkOnly. 'close (myFD);' translateOnly. super destruct.! {void} registerFor: anFD {int} myFD _ anFD. CloseExecutor registerHolder: self with: anFD. ServerLoop introduceChunk: self! ! !FDListener methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FDListener class instanceVariableNames: ''! (FDListener getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #EQ; yourself)! !FDListener class methodsFor: 'smalltalk: init'! initTimeNonInherited ' #ifdef unix signal(SIGPIPE, SIG_IGN); #endif ' translateOnly! ! !FDListener class methodsFor: 'exceptions: exceptions'! problems.SOCKET.U.ERRS ^self signals: #(SOCKET.U.RECV.U.ERROR SOCKET.U.SEND.U.ERROR)! !FDListener subclass: #IPPromiseListener instanceVariableNames: ' myManager {PromiseManager} mySession {FeSession} myPortal {PacketPortal}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-rcmain'! IPPromiseListener comment: 'A IPConnectionListener is associated with the FD of a socket connection to a frontend. Its handleInput method is used to invoke a waitForAndProcessMessage method to handle messages from the frontend.'! (IPPromiseListener getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !IPPromiseListener methodsFor: 'protected: destruct'! {void} destruct mySession _ NULL. myPortal _ NULL. myManager destroy. myManager _ NULL. super destruct! ! !IPPromiseListener methodsFor: 'creation'! create: aSocket {int} super create. CurrentChunk _ self. myPortal _ SocketPortal make: aSocket. myManager _ PromiseManager make: myPortal. self registerFor: aSocket. FePromiseSession make: (UInt8Array string: 'socket') with: self with: myManager. CurrentChunk _ NULL.! ! !IPPromiseListener methodsFor: 'testing'! {BooleanVar} shouldBeReady | result {BooleanVar} | result := self destroyPending not. result ifFalse: [self destroyOKIfRequested]. [^result] smalltalkOnly. ' #if defined(WIN32) | defined(HIGHC) return result; #else if (!!result) { return FALSE; } size_t nready; ioctl (this->descriptor (), FIONREAD, &nready); return nready > 0; #endif /* WIN32 */ ' translateOnly! ! !IPPromiseListener methodsFor: 'accessing'! {BooleanVar} execute "Attempt to execute another chunk. Return whether there is more to be done." (myPortal readStream cast: XnBufferedReadStream) isReady ifFalse: [^false]. CurrentChunk _ self. FDListener problems.SOCKET.U.ERRS handle: [:ex | '/*cerr << &PROBLEM(ex);*/' translateOnly. 'operator<<(cerr ,(Problem*)&PROBLEM(ex));' translateOnly. cerr << ' Connection closed. '. CurrentChunk _ NULL. self destroy. self destroyOKIfRequested. ^false] do: [ self inRequest. myManager handleRequest. self notInRequest]. CurrentChunk _ NULL. self destroyOKIfRequested ifTrue: [^ false] ifFalse: [^(myPortal readStream cast: XnBufferedReadStream) isReady]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! IPPromiseListener class instanceVariableNames: ''! (IPPromiseListener getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !IPPromiseListener class methodsFor: 'creation'! {FDListener} make: aSocket {int} ^self create: aSocket.! !FDListener subclass: #IPRendezvousListener instanceVariableNames: 'myAddress {UInt32}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-rcmain'! IPRendezvousListener comment: 'An IPRendezvousListener binds to a known rendezvous socket address. Its handleInput method accepts connection on this socket and sets up a FEBE connection on the spawned socket, including a IPConnectionListener.'! (IPRendezvousListener getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); add: #NOT.A.TYPE; yourself)! !IPRendezvousListener methodsFor: 'hooks:'! {void RECEIVE.HOOK} restartIPRendezvous: rcvr {Rcvr unused default: NULL} | aSocket {int} | [aSocket _ UnixSocketAccessor newTCPserverAtPort: myAddress. aSocket listenFor: 5] smalltalkOnly. ' #ifdef NETMNG #define SOCKA_SIZE sizeof(struct sockaddr) struct sockaddr * sockName = (struct sockaddr *)falloc(SOCKA_SIZE); #else #define SOCKA_SIZE sizeof(struct sockaddr_in) struct sockaddr_in * sockName = (struct sockaddr_in *)falloc(SOCKA_SIZE); #endif #ifdef UndeFIned_FALSE #define SOCKA_SIZE sizeof(struct sockaddr) struct sockaddr * sockName = (struct sockaddr *)falloc(SOCKA_SIZE); #endif #ifdef GNU #define SOCK_CAST #else #define SOCK_CAST (sockaddr *) #endif sockName->sin_family = AF_INET; sockName->sin_port = htons((unsigned short)myAddress); sockName->sin_addr.s_addr = INADDR_ANY; aSocket = socket (PF_INET, SOCK_STREAM, IPPROTO_TCP); if (aSocket < 0) { BLAST(CANT_OPEN_RENDEZVOUS_SOCKET); } if (bind ( aSocket, SOCK_CAST sockName, SOCKA_SIZE) < 0) { BLAST(CANT_BIND_RENDEZVOUS_SOCKET); } if (listen (aSocket, 5) < 0) { BLAST(SOCKET_LISTEN_FAILED); } ' translateOnly. self registerFor: aSocket! ! !IPRendezvousListener methodsFor: 'creation'! create: anAddress {UInt32} super create. myAddress _ anAddress. self restartIPRendezvous: NULL! ! !IPRendezvousListener methodsFor: 'accessing'! {BooleanVar} execute "A client is trying to connect to the rendezvous socket. Accept the connection and spawn an IPconnectionListener for them. NOTE: in smalltalk (only) it is not guarnteed that there is anyone there. so we do a non blocking operation and return quietly if there isn't" | newSocket {int} | [IPPromiseListener] USES. CurrentChunk _ self. [newSocket _ super descriptor acceptNonBlock. newSocket = nil ifTrue: [ ^false ]] smalltalkOnly. ' #ifdef GNU sockaddr_in fromAddr; #else sockaddr fromAddr; #endif int fromAddrLen = sizeof fromAddr; #ifdef NETMNG newSocket = accept (this->descriptor(), &fromAddr, &fromAddrLen); #else newSocket = accept (this->descriptor(), (sockaddr*)&fromAddr, &fromAddrLen); #endif if (newSocket < 0) { CurrentChunk = NULL; BLAST(ACCEPT_FAILURE_ON_RENDEZVOUS_SOCKET); } ' translateOnly. FDListener problems.SOCKET.U.ERRS handle: [:ex | '/*cerr << &PROBLEM(ex);*/' translateOnly. 'operator<<(cerr,(Problem *)&PROBLEM(ex));'translateOnly. cerr << ' Connection aborted. '. CurrentChunk _ NULL. ^false] do: [IPPromiseListener make: newSocket]. CurrentChunk _ NULL. ^false! {BooleanVar} shouldBeReady ^true "since this is not really a connection it is always OK"! ! !IPRendezvousListener methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myAddress _ receiver receiveUInt32. self restartIPRendezvous: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendUInt32: myAddress.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! IPRendezvousListener class instanceVariableNames: ''! (IPRendezvousListener getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); add: #NOT.A.TYPE; yourself)! !IPRendezvousListener class methodsFor: 'creation'! {FDListener} make: anAddress {UInt32} ^self create: anAddress.! !ServerChunk subclass: #TestChunk instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-srvloop'! (TestChunk getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !TestChunk methodsFor: 'accessing'! {void} processInput! ! !TestChunk methodsFor: 'execute'! {BooleanVar} execute ^ false! !Heaper subclass: #SetTable instanceVariableNames: ' myHashEntries {SharedPtrArray} myTally {Int32} myCoordinateSpace {CoordinateSpace}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-SetTable'! SetTable comment: 'SetTable is a table-like object (NOT at true table) that can store multiple values at a single position. See MuTable for comments on the protocol. The reason that this is not a table subclass is because of several ambiguities in the contract. For example, replace for a table implies that the position must be previously occupied, but in a settable the position is occupied only if the exact association (key->value) is present.'! (SetTable getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; add: #COPY; yourself)! !SetTable methodsFor: 'accessing'! {void} at: aKey {Position} introduce: anObject {Heaper} "Store anObject at position aKey; BLAST if position is already occupied (for SetTable, there must be an object that isEqual to anObject at aKey for the position to be considered occupied)" (self at: aKey store: anObject) ifFalse: [Heaper BLAST: #AlreadyInTable]! {BooleanVar} at: aKey {Position} store: anObject {Heaper} "Store anObject at position aKey; return TRUE if store accomplished, FALSE otherwise" | index {Int32 register} entry {TableEntry} | anObject == NULL ifTrue: [Heaper BLAST: #NullInsertion]. self aboutToWrite. self checkSize. index _ aKey hashForEqual \\ myHashEntries count. entry _ (myHashEntries fetch: index) cast: TableEntry. [entry ~~ NULL] whileTrue: [((entry match: aKey) and: [entry matchValue: anObject]) ifTrue: [^false]. entry _ entry fetchNext]. entry _ TableEntry make: aKey with: anObject. entry setNext: ((myHashEntries fetch: index) cast: TableEntry). myHashEntries at: index store: entry. myTally _ myTally + 1. ^true! {void} atInt: index {IntegerVar} introduce: anObject {Heaper} (self atInt: index store: anObject) ifFalse: [Heaper BLAST: #AlreadyInTable]! {BooleanVar} atInt: index {IntegerVar} store: anObject {Heaper} | offset {Int32 register} entry {TableEntry} | anObject == NULL ifTrue: [Heaper BLAST: #NullInsertion]. self aboutToWrite. self checkSize. offset _ (IntegerPos integerHash: index) \\ myHashEntries count. entry _ (myHashEntries fetch: offset) cast: TableEntry. [entry ~~ NULL] whileTrue: [((entry matchInt: index) and: [entry matchValue: anObject]) ifTrue: [^false]. entry _ entry fetchNext]. entry _ TableEntry make.IntegerVar: index with: anObject. entry setNext: ((myHashEntries fetch: offset) cast: TableEntry). myHashEntries at: offset store: entry. myTally _ myTally + 1. ^true! {CoordinateSpace INLINE} coordinateSpace ^ myCoordinateSpace! {IntegerVar INLINE} count ^ Integer IntegerVar: myTally! {XnRegion} domain | result {XnRegion} keys {TableStepper} | result _ self coordinateSpace emptyRegion. (keys _ self stepper) forEach: [ :element {Heaper} | result _ result with: keys position]. ^result! {void} intRemove: index {IntegerVar} with: value {Heaper} (self wipe.IntegerVar: index with: value) ifFalse: [Heaper BLAST: #NotInTable]! {void} remove: key {Position} with: value {Heaper} (self wipeAssociation: key with: value) ifFalse: [Heaper BLAST: #NotInTable]! {BooleanVar} wipe.IntegerVar: index {IntegerVar} with: value {Heaper} | offset {Int32 register} prev {TableEntry} entry {TableEntry} | offset _ (IntegerPos integerHash: index) \\ myHashEntries count. entry _ (myHashEntries fetch: offset) cast: TableEntry. prev _ entry. [entry ~~ NULL] whileTrue: [((entry matchInt: index) and: [entry matchValue: value]) ifTrue: [self aboutToWrite. (entry isEqual: prev) ifTrue: [myHashEntries at: offset store: entry fetchNext] ifFalse: [prev setNext: entry fetchNext]. entry destroy. entry _ NULL. prev _ NULL. myTally _ myTally - 1. ^true]. prev _ entry. entry _ entry fetchNext]. ^false! {BooleanVar} wipeAssociation: key {Position} with: value {Heaper} | offset {Int32 register} prev {TableEntry} entry {TableEntry} | offset _ key hashForEqual \\ myHashEntries count. entry _ (myHashEntries fetch: offset) cast: TableEntry. prev _ NULL. [entry ~~ NULL] whileTrue: [((entry match: key) and: [entry matchValue: value]) ifTrue: [self aboutToWrite. prev == NULL ifTrue: [myHashEntries at: offset store: entry fetchNext] ifFalse: [prev setNext: entry fetchNext]. entry destroy. entry _ prev _ NULL. myTally _ myTally - 1. ^true]. prev _ entry. entry _ entry fetchNext]. ^false! ! !SetTable methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name. self printOnWithSimpleSyntax: oo with: '[' with: ', ' with: ']'! {void} printOnWithSimpleSyntax: oo {ostream reference} with: open {char star} with: sep {char star} with: close {char star} | stomp {TableStepper} | oo << open. self isEmpty ifTrue: [oo << 'empty'] ifFalse: [stomp _ self stepper. oo << stomp position << '->' << stomp fetch. stomp step. stomp forEach: [:val {Heaper} | oo << sep << stomp position << '->' << val]]. oo << close! ! !SetTable methodsFor: 'runLength'! {XnRegion} runAt: index {Position} (self includesKey: index) ifTrue: [^ index asRegion] ifFalse: [^ myCoordinateSpace emptyRegion]! {XnRegion} runAtInt: index {IntegerVar} ^ self runAt: index integer! ! !SetTable methodsFor: 'enumerating'! {TableStepper} stepper: order {OrderSpec default: NULL} "ignore order spec for now" order == NULL ifTrue: [^TableEntry bucketStepper: myHashEntries] ifFalse: [self unimplemented. ^NULL "fodder"]! {Stepper} stepperAt: key {Position} | offset {Int32 register} elements {PrimSet} entry {TableEntry wimpy} | offset _ key hashForEqual \\ myHashEntries count. elements _ PrimSet make. entry _ (myHashEntries fetch: offset) cast: TableEntry. [entry ~~ NULL] whileTrue: [(entry match: key) ifTrue: [elements introduce: entry value]. entry _ entry fetchNext]. ^elements stepper! {Stepper} stepperAtInt: index {IntegerVar} | offset {Int32 register} elements {PtrArray} entry {TableEntry wimpy} i {Int32} | offset _ (IntegerPos integerHash: index) \\ myHashEntries count. elements _ SetTableStepper array. i _ Int32Zero. entry _ (myHashEntries fetch: offset) cast: TableEntry. [entry ~~ NULL] whileTrue: [(entry matchInt: index) ifTrue: [ i >= elements count ifTrue: [elements _ (elements copyGrow: 4) cast: PtrArray]. elements at: i store: entry value. i := i + 1]. entry _ entry fetchNext]. ^SetTableStepper make: elements.! ! !SetTable methodsFor: 'creation'! create: entries {SharedPtrArray of: TableEntry} with: tally {Int32} with: cs {CoordinateSpace} super create. myHashEntries _ entries. myTally _ tally. myCoordinateSpace _ cs. myHashEntries shareMore! {void} destruct myHashEntries shareLess. super destruct! {SetTable INLINE} emptySize: size {IntegerVar} "return an empty table just like the current one" ^SetTable make: myCoordinateSpace with: size! ! !SetTable methodsFor: 'smalltalk:'! stepper ^self stepper: NULL! ! !SetTable methodsFor: 'testing'! {BooleanVar} at: key {Position} includes: value {Heaper} (self stepperAt: key) forEach: [:val {Heaper} | (val isEqual: value) ifTrue: [^true]]. ^false! {BooleanVar} includesKey: aKey {Position} | stp {Stepper} result {BooleanVar} | stp _ self stepperAt: aKey. result _ stp hasValue. stp destroy. ^result! {BooleanVar} isEmpty ^self count == IntegerVar0! ! !SetTable methodsFor: 'private: resize'! {void} aboutToWrite "If my contents are shared, and I'm about to change them, make a copy of them." myHashEntries shareCount > 1 ifTrue: [| newEntries {SharedPtrArray of: TableEntry} entryCount {Int32} | entryCount _ myHashEntries count. newEntries _ SharedPtrArray make: entryCount. Int32Zero almostTo: entryCount do: [:index {Int32} | | entry {TableEntry wimpy} | (entry _ (myHashEntries fetch: index) cast: TableEntry) ~~ NULL ifTrue: [| newEntry {TableEntry} | newEntry _ entry copy. newEntries at: index store: newEntry. entry _ entry fetchNext. [entry ~~ NULL] whileTrue: [newEntry setNext: entry copy. newEntry _ newEntry fetchNext. entry _ entry fetchNext]]]. myHashEntries shareLess. myHashEntries _ newEntries. myHashEntries shareMore]! {void} checkSize | oldEntries {SharedPtrArray} oldSize {Int32} newSize {Int32} | myTally > (myHashEntries count * 3) ifTrue: [oldSize _ myHashEntries count. newSize _ PrimeSizeProvider make uInt32PrimeAfter: (oldSize * 4). myHashEntries shareLess. oldEntries _ myHashEntries. myHashEntries _ SharedPtrArray make: newSize. myHashEntries shareMore. Int32Zero almostTo: oldSize do: [:j {Int32 register} | | cur {TableEntry} next {TableEntry} | cur _ (oldEntries fetch: j) cast: TableEntry. [cur ~~ NULL] whileTrue: [next _ cur fetchNext. self storeEntry: cur. cur _ next]]. oldEntries destroy]! {void} storeEntry: entry {TableEntry} | idx {UInt32} | (myCoordinateSpace isEqual: IntegerSpace make) ifTrue: [idx _ IntegerPos integerHash: entry index ] ifFalse: [idx _ entry position hashForEqual]. idx _ idx \\ myHashEntries count. entry setNext: ((myHashEntries fetch: idx) cast: TableEntry). myHashEntries at: idx store: entry! ! !SetTable methodsFor: 'smalltalk: private: smalltalk private'! {void} inspect ^InspectorView open: (SetTableInspector inspect: self)! ! !SetTable methodsFor: 'generated:'! actualHashForEqual ^self asOop! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myHashEntries _ receiver receiveHeaper. myTally _ receiver receiveInt32. myCoordinateSpace _ receiver receiveHeaper.! isEqual: other ^self == other! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myHashEntries. xmtr sendInt32: myTally. xmtr sendHeaper: myCoordinateSpace.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! SetTable class instanceVariableNames: ''! (SetTable getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; add: #COPY; yourself)! !SetTable class methodsFor: 'creation'! {SetTable INLINE} make: cs {CoordinateSpace} ^self make: cs with: 7! make: cs {CoordinateSpace} with: size {IntegerVar} ^self create: (SharedPtrArray make: (size DOTasLong bitOr: 1)) with: Int32Zero with: cs! !Heaper subclass: #SHTO instanceVariableNames: ' myHashValue {UInt4} myStringValue {Sequence}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-set'! SHTO comment: 'SHTO (SpecialHashTestObject) is used for testing hash sets. It stores an identifying string, along with the hash that it is to return. This allows a) system independent testing - as the hash will be the same in all test output files, and b) provides for testing complex hash value interactions with spending years looking for the right objects to generate critical hash values.'! (SHTO getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !SHTO methodsFor: 'tests'! {UInt32} actualHashForEqual ^ myHashValue! {BooleanVar} isEqual: other {Heaper} other cast: SHTO into: [:foo {SHTO} | ^myHashValue = foo hashForEqual and: [myStringValue isEqual: foo stringValue]] others: [ ^false]. ^false "fodder"! ! !SHTO methodsFor: 'creation'! create: onString {Sequence} with: onHash {UInt32} super create. myStringValue _ onString. myHashValue _ onHash! ! !SHTO methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '('. [myHashValue printOn: oo base: 16] smalltalkOnly. '{ char buffer[9]; sprintf(buffer, "%X", myHashValue); oo << buffer; }' translateOnly. oo << ', ' << myStringValue << ')'! ! !SHTO methodsFor: 'private: accessing'! {Sequence} stringValue ^ myStringValue! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! SHTO class instanceVariableNames: ''! (SHTO getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !SHTO class methodsFor: 'make'! make: aString {char vector} with: aHashVal {UInt32} | pack {Sequence} | pack _ Sequence string: aString. ^ self create: pack with: aHashVal! !Heaper subclass: #SnarfHandler instanceVariableNames: ' myHandle {SnarfHandle star} myMapCount {Int4} mySpaceLeft {Int4} myNearest {Int4}' classVariableNames: ' Flag {UInt4} SizeOffset {Int4} UseFences {BooleanVar} Value {UInt4} ' poolDictionaries: '' category: 'Xanadu-Snarf'! SnarfHandler comment: 'A SnarfHandler breaks a snarf into abstract subarrays of bytes into whic flocks are stored. These indexed flock storage areas are accessed through readStreams and writeStreams provided by the SnarfHandler. SnarfHandlers also provide the ability to resize these flock areas and associate a couple of flag bits with them. All access to the snarf goes through a single snarfHandler. The beginning of the snarf is dedicated to a table that describes the locations and sizes of the contained flock areas. Currently, we allocate space between the flock nearest the front of the snarf and the end of the mapTable. When not enough space exists between the two, we compact the flock storage areas towards the back (highest address) of the snarf and try to allocate again. An index in the snarfHAndler can be associated either with one of these flock storage areas or with a snarfID and index to look further for the storage of a given flock. Right now, the SnarfHAndler keeps the forwarding information in a flock storage area, but it will soon be put into the mapTable directly. Forwarding pointers occur when a flock outgrows a snarf, and must be moved elsewhere. Eventually all other snarfs that have objects which point to the forwarding pointer are updated, and the forwarding pointer can be deallocated, but decisions about this must be made by objects external to the SnarfHandler. The forwarded flag is stored on the snarfID. The forgotten flag is stored on the size. Both use the same Flag mask for accessing the flag, and the Value mask for accessing the value.'! (SnarfHandler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !SnarfHandler methodsFor: 'reading'! {FlockLocation | NULL} fetchForward: index {Int32} "If the flock specified by index has been forwarded, return a FlockLocation with the SnarfID and index of its new location." self checkIndex: index. (self isForwarded: index) ifTrue: ["Forwarded. The info is stored in the mapCell." ^FlockLocation make: (self getOffset: index) with: (self getSize: index)]. ^NULL! {Int32} flockSize: index {Int32} "Return the number of bytes in the flock at index" ^((myHandle get32: (self mapCellOffset: index) + SizeOffset) bitAnd: Value) - (SnarfHandler fenceSize * 2)! {BooleanVar} isForgotten: index {Int32} "The forgotten flag is the flag bit associated with each flock. It is set when the flock has been forgotten, which means that there are no more persistent pointers to the flock. When a flock is forgotten AND is not in RAM, the SnarfPacker is free to bring the flock back into RAM and destroy it, which deletes it from the snarf. Return true if the forgotten flag has been set for the flock at index." ^(Flag bitAnd: (myHandle get32: (self mapCellOffset: index) + SizeOffset)) == Flag! {BooleanVar} isOccupied: index {Int32} "Return true if there's a flock or forwarder at index." ^index >= Int32Zero and: [index < myMapCount and: [(self isForwarded: index) or: [(self getSize: index) > Int32Zero]]]! {Int32} mapCount "Return the number of slots allocated in the map table." ^myMapCount! {XnReadStream} readStream: index {Int32} "Return a stream on the area of the snarf allocated to mapIndex. This stream must be used immediately, then thrown away." self checkIndex: index. (self isForwarded: index) ifTrue: [Heaper BLAST: #MustBeAFlock]. ^XnReadStream make: myHandle getDataP with: (self flockOffset: index) with: (self flockSize: index)! {SnarfID} snarfID "Return the snarfID of the snarf this handle holds." ^myHandle getSnarfID! {Int32} spaceLeft "Return the amount space left in the snarf." ^mySpaceLeft! ! !SnarfHandler methodsFor: 'writing'! {void} allocateCells: indices {IntegerVar} "Add more cells to the mapTable. Make sure that there is enough space for those cells, then initialize. The size is initially 0 and the offset points past the end of the snarf." | newCells {Int32} space {Int32} | newCells _ indices DOTasLong. newCells <= Int32Zero ifTrue: [^VOID]. space _ newCells * SnarfHandler mapCellSize. self clearSpace: space. myMapCount _ myMapCount + newCells. mySpaceLeft _ mySpaceLeft - space. myMapCount-newCells almostTo: myMapCount do: [:index {Int32} | "Zero all the counts, just like wipeFlock." myHandle at: (self mapCellOffset: index) + SizeOffset put32: Int32Zero. self at: index storeIndex: self flocksEnd]. self consistencyCheck. self checkFences! {void} at: ind {IntegerVar} allocate: flockSize {Int32} "Allocate flockSize bytes for the flock at the index ind." | index {Int32} size {Int32} | flockSize > Int32Zero assert: 'Must allocate some space'. size _ flockSize + (SnarfHandler fenceSize * 2). index _ ind DOTasLong. self checkIndex: index. self clearSpace: size. (self isForwarded: index) ifFalse: [mySpaceLeft _ mySpaceLeft + (self getSize: index)]. mySpaceLeft _ mySpaceLeft - size. self at: index storeIndex: self nearestFlock - size. self at: index storeSize: size. self mendFences: index. self consistencyCheck. self checkFences! {void} at: index {Int32} storeForget: flag {BooleanVar} "See the comment on isForgotten:. Set or clear the forgetFlag for the flock at index." | offset {Int32} | self checkIndex: index. offset _ (self mapCellOffset: index) + SizeOffset. "Keep everything else the same." flag ifTrue: [myHandle at: offset put32: (Flag bitOr: (myHandle get32: offset))] ifFalse: [myHandle at: offset put32: (Value bitAnd: (myHandle get32: offset))]. self checkFences! {void} forward: index {IntegerVar} to: newSnarfID {SnarfID} with: newIndex {Int32} "Associate a forwarder with index. Throw away whatever storage was assigned to it and store the forwarder information in the mapCell." self wipeFlock: index. myHandle at: (self mapCellOffset: index DOTasLong) put32: (newSnarfID bitOr: Flag). myHandle at: ((self mapCellOffset: index DOTasLong) + SizeOffset) put32: (newIndex bitAnd: Value).! {BooleanVar} isWritable "Return true if I represent a writable snarf. " ^myHandle isWritable! {void} makeWritable "Make the handle for the receiver writable." myHandle makeWritable! {void} rewrite "Write out to the snarf any values held in instance variables (space remaining, number of entries, etc.)." myHandle at: Int32Zero put32: myMapCount. myHandle at: SizeOffset put32: mySpaceLeft! {void} wipeFlock: index {IntegerVar} "Deallocate all space for the flock at index. The slot for index remains however, and can be reused for another flock." self checkIndex: index DOTasLong. (self isForwarded: index DOTasLong) ifFalse: [mySpaceLeft _ mySpaceLeft + (self getSize: index DOTasLong)]. myHandle at: (self mapCellOffset: index DOTasLong) + SizeOffset put32: Int32Zero. self at: index DOTasLong storeIndex: self flocksEnd. self consistencyCheck. self checkFences! {XnWriteStream} writeStream: index {IntegerVar} "Return a stream that can write into the bytes allocated to the flock at index. The stream must be used immediately and thrown away." self checkIndex: index DOTasLong. (self isForwarded: index DOTasLong) ifTrue: [Heaper BLAST: #MustBeAFlock]. ^XnWriteStream make: myHandle getDataP with: (self flockOffset: index DOTasLong) with: (self flockSize: index DOTasLong)! ! !SnarfHandler methodsFor: 'initialize'! {void} initializeSnarf "Put in the minimum necessary for a starting snarf. All it needs is the number of objects and the spaceLeft. This also writes the information to the real snarf." myMapCount _ Int32Zero. mySpaceLeft _ self flocksEnd - SnarfHandler mapOverhead. self rewrite! ! !SnarfHandler methodsFor: 'private: operations'! {BooleanVar} checkFence: index {Int32} "If we are using fences around flock storage areas, then return true only if the fences are still in place for the flock at index. Fences are extra storage at the front and back of a flock storage area that contains the index of that flock. These are used for runtime checks that one flock hasn't stepped into the space of another." UseFences ifTrue: [| offset {Int32} size {Int32} | (self isForwarded: index) ifTrue: [^true]. size _ self getSize: index. ^size <= Int32Zero or: [(myHandle get32: (offset _ self getOffset: index)) == index and: [(myHandle get32: offset + (self getSize: index) - SnarfHandler fenceSize) == index]]] ifFalse: [^true]! {void} checkFences "See checkFence: Check the fences for all flocks and blast if any are violated." "Int32Zero to: myMapCount-1 do: [:i {Int32} | (self checkFence: i) ifFalse: [SnarfHandler BLAST: #BrokenFence]]"! {void} checkIndex: index {Int32} "Blast if the index is not represented in the table. This is just simple bounds checking." (index >= myMapCount and: [index >= Int32Zero]) ifTrue: [MuTable BLAST: #NotInTable]! {void} clearSpace: count {Int32} "This checks for count bytes available at the end of the mapTable. If there isn't enough, it compacts everything and tries again." self consistencyCheck. self nearestFlock < (self mapEnd + count) ifTrue: [self recomputeNearest. self nearestFlock < (self mapEnd + count) ifTrue: [self compact. self nearestFlock >= (self mapEnd + count) ifFalse: [Heaper BLAST: #MustHaveRoom]]]! {void} compact "Compress flock storage areas towards the end of the snarf, leaving all freespace between the end of the mapTable and the nearest flock." | sweeper {Int32} offsets {UInt32Array} indices {UInt32Array} | self checkFences. sweeper _ self flocksEnd. myNearest _ sweeper. "Load up all the offset into an array. Make cells that are forwarded just point past the end of the snarf." offsets _ UInt32Array make: myMapCount + 1. Int32Zero almostTo: myMapCount do: [ :i {Int32} | (self isForwarded: i) ifTrue: [offsets at: i storeUInt: sweeper] ifFalse: [offsets at: i storeUInt: (self getOffset: i)]]. offsets at: myMapCount storeUInt: UInt32Zero. indices _ SnarfHandler sort: offsets. Int32Zero almostTo: myMapCount do: [:i2 {Int32} | | indexToMove {Int32} offsetToMove {Int32} count {Int32} | indexToMove _ indices uIntAt: i2. offsetToMove _ offsets uIntAt: i2. offsetToMove < sweeper ifTrue: [count _ self getSize: indexToMove. sweeper _ sweeper - count. myHandle moveBytes: offsetToMove with: sweeper with: count. "This storeIndex will also push myNearest." self at: indexToMove storeIndex: sweeper]]. self checkFences. offsets destroy.! {void} consistencyCheck "Generic checking hook to do slow runtime consistency checking when debugging. No checks are active currently." "self compact. mySpaceLeft == (self nearestFlock - self mapEnd) assert: 'space mismatch'." "| sum {Int32} | sum _ Int32Zero. Int32Zero almostTo: myMapCount do: [:i {Int32} | (self isForwarded: i) ifFalse: [sum _ sum + (self getSize: i)]]. sum + self mapEnd + mySpaceLeft == myHandle getDataSize assert: 'Space difference'"! {void} mendFences: index {Int32} "Couldn't resist the name. Set up the fences for the flock at index. See checkFence:" UseFences ifTrue: [| offset {Int32} | offset _ self getOffset: index. myHandle at: offset put32: index. myHandle at: offset + (self getSize: index) - SnarfHandler fenceSize put32: index]! {Int32} nearestFlock "Return the location of the nearest flock. Everything between the end of the map and the nearest flock is free space. We normally allocate everything from the back of the snarf forward. When we run out of enough contiguous space, we simply compact. We keep a cache of the current nearest flock. The cache maintins the invariant that it *must* point to an offset less than or equal to the nearestFlock. Thus it can be too close to the mapTable, in which case we will recompute it from scratch." myNearest == Int32Zero ifTrue: [self recomputeNearest]. ^myNearest! {void} recomputeNearest "Recalculate the nearest flock by looking at the start of every flock and taking the min." myNearest _ self flocksEnd. Int32Zero almostTo: myMapCount do: [:index {Int32} | ((self isForwarded: index) not and: [(self getSize: index) > Int32Zero]) ifTrue: [| offset {Int32} | offset _ self getOffset: index. offset < myNearest ifTrue: [myNearest _ offset]]]! ! !SnarfHandler methodsFor: 'private: layout'! {void} at: index {Int32} storeIndex: offset {Int32} "Store the offset as the starting location for the data of the flock at index. Update the cache of nearestFlock. This also clears the forwarded flag." offset < myNearest ifTrue: [myNearest _ offset]. myHandle at: (self mapCellOffset: index) put32: (offset bitAnd: Value)! {void} at: index {Int32} storeSize: size {Int32} "Store size as the number of bytes for the flock at index. If the space is at a 0, then change the corresponding pointer to past the end of the snarf so that we don't find it in our searches." | offset {Int32} | offset _ (self mapCellOffset: index) + SizeOffset. "Keep the old flags." myHandle at: offset put32: ((size bitAnd: Value) bitOr: ((myHandle get32: offset) bitAnd: Flag)). size == Int32Zero ifTrue: [self at: index storeIndex: self flocksEnd]! {Int32} flockOffset: index {Int32} "Return the index of the first byte of the actual data associated with flock number index. This is like indexOf: except that it leaves room for fencePosts on either side of the flock storage area." ^((myHandle get32: (self mapCellOffset: index)) bitAnd: Value) + SnarfHandler fenceSize! {Int32} flocksEnd "Return the index of the cell one greater than the size of the entire snarf. This is just past the end of the storage area for flocks." ^myHandle getDataSize! {Int32} getOffset: index {Int32} "Return the index of the first byte of the actual data associated with flock number index. This area includes space for fencePosts and whatever other things we might dream up that go with the flock in its storage area." | offset {Int32} | offset _ myHandle get32: (self mapCellOffset: index). ^offset bitAnd: Value! {Int32} getSize: index {Int32} "Return the number of bytes in the flock at index. This includes space allocated internally for fencePosts and the like." | size {Int32} | size _ (myHandle get32: (self mapCellOffset: index) + SizeOffset) bitAnd: Value. ^size! {BooleanVar} isForwarded: index {Int32} "Return the internal bit that says whether the flock at index is represented by forwarding information or by a flock area" ^(Flag bitAnd: (myHandle get32: (self mapCellOffset: index))) == Flag! {Int32 INLINE} mapCellOffset: index {Int32} "Return the offset into the snarf for the mapCell that has the data for the flock at index." ^(SnarfHandler mapCellSize * index) + SnarfHandler mapOverhead! {Int32} mapEnd "Return the index of the cell just after the end of the map. This is based on the number of entries in the map." ^self mapCellOffset: myMapCount! {Int32} snarfMapCount "Actually get from the snarf the number of map slots currently allocated, including ones that are free for reuse. This is stored as the first thing in the snarf." ^myHandle get32: Int32Zero! {Int32} snarfSpaceLeft "Actually get from the snarf the amount of unallocated space remaining." ^myHandle get32: SizeOffset! ! !SnarfHandler methodsFor: 'protected: destruct'! {void} destruct "Write my internal constants to the snarf before I go away." myHandle isWritable ifTrue: [self rewrite]. myHandle destroy. myHandle _ NULL. super destruct! ! !SnarfHandler methodsFor: 'create'! create: handle {SnarfHandle} super create. [handle ~~ nil assert: 'nil handle'] smalltalkOnly. myHandle _ handle. myMapCount _ self snarfMapCount. "If I'm uninitialized, then generate the necessary data." myMapCount == Int32Zero ifTrue: [mySpaceLeft _ self flocksEnd - SnarfHandler mapOverhead] ifFalse: [mySpaceLeft _ self snarfSpaceLeft]. myNearest _ Int32Zero! ! !SnarfHandler methodsFor: 'smalltalk: debugging'! inspect ^InspectorView open: (SnarfHandlerInspector inspect: self)! ! !SnarfHandler methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! SnarfHandler class instanceVariableNames: ''! (SnarfHandler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !SnarfHandler class methodsFor: 'smalltalk: initialization'! linkTimeNonInherited self hack. "These don't use the full 32 bits so that we don't start manipulating LargeIntegers." Flag _ 1 bitShift: 25. Value _ (1 bitShift: 25) - 1"Flag - 1". SizeOffset _ 4 "The offset of the size from the begginging of a mapCell". UseFences _ false! ! !SnarfHandler class methodsFor: 'pcreate'! make: snarfHandle {SnarfHandle} ^self create: snarfHandle! ! !SnarfHandler class methodsFor: 'accessing'! {Int32} fenceSize "The number of bytes for one fence (Each flock requires two)." UseFences ifTrue: [^4] ifFalse: [^Int32Zero]! {Int32 INLINE} mapCellOverhead "Return the number of bytes for a single map record, plus the space for the fence. The fence will be just the index of the flock stored at the beginning and the end of the flock's memory" ^self mapCellSize + SnarfHandler fenceSize + SnarfHandler fenceSize! {Int32 INLINE} mapCellSize "Return the number of bytes for a single map record." ^8! {Int32 INLINE} mapOverhead "The map starts just after the basic header. The basic header currently has the number of entries in the map and total amount of free space remaining." ^8! ! !SnarfHandler class methodsFor: 'smalltalk: testing'! {Pair of: UInt32Array with: UInt32Array} sortTest: array {Array of: IntegerVar} "self sortTest: #(2 3 4 1). self sortTest: #(). self sortTest: #(1000 1000 1000). self sortTest: #(1 2 3 4). self sortTest: #(1). self sortTest: #(2 2 3 3 4 4 1 1)." | offsets {UInt32Array} indices {UInt32Array} | offsets _ UInt32Array make: array size + 1. 1 to: array size do: [:i {IntegerVar} | offsets at: i - 1 store: (array at: i)]. offsets at: array size store: 1000. indices _ self sort: offsets with: (IntegerSpace make getAscending). ^Pair make: offsets with: indices.! {Pair of: UInt32Array with: UInt32Array} sortTestDown: array {Array of: IntegerVar} "self sortTestDown: #(2 3 4 1). self sortTestDown: #(). self sortTestDown: #(1000 1000 1000). self sortTestDown: #(1 2 3 4). self sortTestDown: #(1). self sortTestDown: #(2 2 3 3 4 4 1 1)." | offsets {UInt32Array} indices {UInt32Array} | offsets _ UInt32Array make: array size + 1. 1 to: array size do: [:i {IntegerVar} | offsets at: i - 1 store: (array at: i)]. offsets at: array size store: 1. indices _ self sort: offsets with: (IntegerSpace make getDescending). ^Pair make: offsets with: indices.! ! !SnarfHandler class methodsFor: 'private: sorting'! {void} quickSort: offsets {UInt32Array} with: indices {UInt32Array} with: first {Int32} with: last {Int32} | part {Int32} left {Int32} right {Int32} | first >= last ifTrue: [^VOID]. left _ first. right _ last + 1. self swap: offsets with: first with: (left + right) // 2. self swap: indices with: first with: (left + right) // 2. part _ offsets uIntAt: first. [left < right] whileTrue: [left _ left + 1. [(offsets uIntAt: left) > part] whileTrue: [left _ left + 1]. right _ right - 1. [part > (offsets uIntAt: right)] whileTrue: [right _ right -1]. left < right ifTrue: [self swap: offsets with: left with: right. self swap: indices with: left with: right]]. self swap: offsets with: first with: right. self swap: indices with: first with: right. self quickSort: offsets with: indices with: first with: right - 1. self quickSort: offsets with: indices with: right + 1 with: last! {void} quickSort: offsets {UInt32Array} with: indices {UInt32Array} with: os {OrderSpec} with: first {IntegerVar} with: last {IntegerVar} | part {IntegerVar} left {IntegerVar} right {IntegerVar} | first >= last ifTrue: [^VOID]. left _ first. right _ last + 1. self swap: offsets with: first with: (left + right) // 2. self swap: indices with: first with: (left + right) // 2. part _ offsets uIntAt: first DOTasLong. [left < right] whileTrue: [left _ left + 1. [os followsInt: (offsets uIntAt: left DOTasLong) with: part] whileFalse: [left _ left + 1]. right _ right - 1. [(os followsInt: part with: (offsets uIntAt: right DOTasLong))] whileFalse: [right _ right -1]. left < right ifTrue: [self swap: offsets with: left with: right. self swap: indices with: left with: right]]. self swap: offsets with: first with: right. self swap: indices with: first with: right. self quickSort: offsets with: indices with: os with: first with: right - 1. self quickSort: offsets with: indices with: os with: right + 1 with: last! {UInt32Array} sort: offsets {UInt32Array} "Sort the offsets array in place, and return an array of the same size that maps from the new index of each element to its original index. The offsets array is *assumed* to be terminated with a guard element which is greater than or equal to all the other elements of the array according to descending order. If this isn't true, havoc may result." | result {UInt32Array} | result _ UInt32Array make: offsets count. Int32Zero almostTo: offsets count do: [:i {Int32} | result at: i storeUInt: i]. self quickSort: offsets with: result with: Int32Zero with: offsets count - 2. ^result! {UInt32Array} sort: offsets {UInt32Array} with: os {OrderSpec} "Sort the offsets array in place, and return an array of the same size that maps from the new index of each element to its original index. The offsets array is *assumed* to be terminated with a guard element which is greater than or equal to all the other elements of the array according to the sorting order. If this isn't true, havoc may result." | result {UInt32Array} | result _ UInt32Array make: offsets count. Int32Zero almostTo: offsets count do: [:i {Int32} | result at: i storeUInt: i]. self quickSort: offsets with: result with: os with: Int32Zero with: offsets count - 2. ^result! {void INLINE} swap: array {UInt32Array} with: i {IntegerVar} with: j {IntegerVar} | temp {UInt32} | temp _ array uIntAt: i DOTasLong. array at: i DOTasLong storeUInt: (array uIntAt: j DOTasLong). array at: j DOTasLong storeUInt: temp! !Heaper subclass: #SnarfInfoHandler instanceVariableNames: ' mySnarfs {MuTable of: SnarfHandle} myTotal {Int4} myCurrentHandle {SnarfHandle} myCurrentStart {Int4} myCurrentIndex {IntegerVar}' classVariableNames: ' ForgottenFlag {Int4 const} SizeMask {Int4 const} ' poolDictionaries: '' category: 'Xanadu-Urdi'! SnarfInfoHandler comment: 'The SnarfInfoHandler is an interface to the first few snarfs in an urdi that tells how much space is unallocated in each of the remaining snarfs, and keeps a bit as to whether any forgotten objects are in each snarf. The data is kept packed in the first few snarfs with 4 bytes per snarf recorded. The forgotten bit is the high bit of each entry. mySnarfs is a table of SnarfHandles onto the snarfInfo snarfs (the first few snarfs in the Urdi). You release those snarfs by destroying the snarfInfoHandler and creating a new one when you want the information again. myTotal is the total number of snarfs in the Urdi.'! (SnarfInfoHandler getOrMakeCxxClassDescription) friends: '/* friends for class SnarfInfoHandler */ friend class SnarfInfoStepper;'; attributes: ((Set new) add: #CONCRETE; yourself)! !SnarfInfoHandler methodsFor: 'accessing'! {BooleanVar} getForgottenFlag: snarfID {SnarfID} "Return the forgotten bit for the snarf at snarfID." | offset {Int32} | offset _ self locate: snarfID. ^((myCurrentHandle get32: offset) bitAnd: ForgottenFlag) ~~ Int32Zero! {Int32} getSpaceLeft: snarfID {SnarfID} "Return the spaceLeft for the snarf at snarfID." | offset {Int32} | offset _ self locate: snarfID. ^(myCurrentHandle get32: offset) bitAnd: SizeMask! {void} setForgottenFlag: snarfID {SnarfID} with: flag {BooleanVar} "Set or clear the forgotten bit for the snarf at snarfID." | offset {Int32} | offset _ self locate: snarfID. myCurrentHandle makeWritable. flag ifTrue: [myCurrentHandle at: offset put32: ((myCurrentHandle get32: offset) bitOr: ForgottenFlag)] ifFalse: [myCurrentHandle at: offset put32: ((myCurrentHandle get32: offset) bitAnd: ForgottenFlag bitInvert)]! {void} setSpaceLeft: snarfID {SnarfID} with: space {Int32} "Set the space for the snarf at snarfID." | offset {Int32} | offset _ self locate: snarfID. myCurrentHandle makeWritable. myCurrentHandle at: offset put32: space + ((myCurrentHandle get32: offset) bitAnd: SizeMask bitInvert)! {Int32} snarfCount "Return the total number of snarfs in the urdi." ^myTotal! {Int32} snarfInfoCount "Return the number of snarfs that the snarf info information takes up. This is used to know what snarf to get the first object from." ^mySnarfs count DOTasLong! ! !SnarfInfoHandler methodsFor: 'private:'! {void} initializeSpaceLeft: snarfID {SnarfID} with: space {Int32} "Se the spaceLeft to a certain amount, and clear all the flags. This is used when initializing the snarfInfo so we don't get confused by the flags." | offset {Int32} | offset _ self locate: snarfID. myCurrentHandle makeWritable. myCurrentHandle at: offset put32: space! {Int32} locate: snarfID {SnarfID} "Return the snarfHandle for the snarfInfo snarf that contains the spaceLeft and forgotten flag for the snarf at snarfID." (myCurrentHandle ~~ NULL and: [snarfID >= myCurrentStart and: [snarfID < (myCurrentStart + (myCurrentHandle getDataSize // 4))]]) ifTrue: [^(snarfID - myCurrentStart) * 4]. (snarfID < myCurrentStart or: [myCurrentHandle == NULL]) ifTrue: [myCurrentIndex _ IntegerVar0. myCurrentHandle _ (mySnarfs intGet: myCurrentIndex) cast: SnarfHandle. myCurrentStart _ Int32Zero]. [myCurrentHandle ~~ NULL] whileTrue: [| count {Int32} | count _ myCurrentHandle getDataSize // 4. snarfID < (count + myCurrentStart) ifTrue: [^(snarfID - myCurrentStart) * 4]. myCurrentIndex _ myCurrentIndex + 1. myCurrentHandle _ (mySnarfs intFetch: myCurrentIndex) cast: SnarfHandle. myCurrentStart _ myCurrentStart + count]. Heaper BLAST: #NoSnarfInfo. ^Int32Zero! ! !SnarfInfoHandler methodsFor: 'protected: destruct'! {void} destruct "Release all my handles before going away." myCurrentHandle _ NULL. mySnarfs getCategory ~= Heaper ifTrue: [mySnarfs stepper forEach: [:handle {SnarfHandle} | handle destroy]]. mySnarfs _ NULL. super destruct! ! !SnarfInfoHandler methodsFor: 'create'! create.Urdi: urdi {Urdi} with: view {UrdiView} "This constructor is for a newly created urdi with no existing snarfInfo information. Set the spaceLeft for each snarf to its maximum and clear the forgotten flag. Note that this figures out how many snarfInfo snarfs to use on the fly by allocating as many snarfInfo cells as it can in the first snarf, then going on to the second snarf, until enough snarfInfo snarfs are allocated. Then it goes through all the entries in the snarfInfo for each non-snarfInfo snarf and set the spaceLeft appropriately." | snarfID {SnarfID} total {Int32} | super create. snarfID _ Int32Zero. myTotal _ urdi usableSnarfs. mySnarfs _ MuArray array. myCurrentStart _ Int32Zero. myCurrentIndex _ IntegerVar0. myCurrentHandle _ NULL. total _ Int32Zero. "Initialize enough snarfInfo snarfs for all snarfs in the Urdi." [total < myTotal] whileTrue: [| handle {SnarfHandle} | handle _ view makeErasingHandle: snarfID. mySnarfs atInt: snarfID introduce: handle. self initializeSpaceLeft: snarfID with: Int32Zero. total _ total + (handle getDataSize // 4). snarfID _ snarfID + 1]. "Initialize the entries for all non-snarfInfo snarfs." snarfID almostTo: myTotal do: [:dataSnarfID {SnarfID} | self initializeSpaceLeft: dataSnarfID with: (urdi getDataSizeOfSnarf: dataSnarfID)]! create.UrdiView: view {UrdiView} with: urdi {Urdi} "This constructor is for reopening an existing urdi and using its existing snarfInfo. Read snarfs until it has enough cells for all snarfs in fthe urdi." | snarfID {SnarfID} total {Int32} | super create. snarfID _ Int32Zero. myTotal _ urdi usableSnarfs. mySnarfs _ MuArray array. myCurrentStart _ Int32Zero. myCurrentIndex _ IntegerVar0. myCurrentHandle _ NULL. total _ UInt32Zero. [total < myTotal] whileTrue: [| handle {SnarfHandle} | handle _ view makeReadHandle: snarfID. mySnarfs atInt: snarfID introduce: handle. total _ total + (handle getDataSize // 4). snarfID _ snarfID + 1]! ! !SnarfInfoHandler methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! SnarfInfoHandler class instanceVariableNames: ''! (SnarfInfoHandler getOrMakeCxxClassDescription) friends: '/* friends for class SnarfInfoHandler */ friend class SnarfInfoStepper;'; attributes: ((Set new) add: #CONCRETE; yourself)! !SnarfInfoHandler class methodsFor: 'pcreate'! {void} initializeSnarfInfo: urdi {Urdi} with: view {UrdiView} | handler {SnarfInfoHandler} | handler _ self create.Urdi: urdi with: view. handler destroy! make: urdi {Urdi} with: view {UrdiView} ^self create.UrdiView: view with: urdi! ! !SnarfInfoHandler class methodsFor: 'smalltalk: initialization'! linkTimeNonInherited "self hack." "These don't use the full 32 bits so that we don't start manipulating LargeIntegers." ForgottenFlag _ 1 bitShift: 24. SizeMask _ "ForgottenFlag - 1"(1 bitShift: 24) - 1.! ! !SnarfInfoHandler class methodsFor: 'smalltalk: create'! create.Urdi: urdi {Urdi} with: view {UrdiView} ^self new create.Urdi: urdi with: view! create.UrdiView: view {UrdiView} with: urdi {Urdi} ^self new create.UrdiView: view with: urdi! !Heaper subclass: #SnarfRecord instanceVariableNames: ' mySnarfID {SnarfID} myPacker {SnarfPacker} mySpaceLeft {Int32} myOccupied {IntegerRegion | NULL} myChangedFlocks {PrimPtrTable of: Abraham} myDestroyCount {Int32}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Snarf'! SnarfRecord comment: 'Manage retrieval, refitting, and rewriting of existing flocks. Assign indices for new flocks. SnarfRecords can go away after their contents have been flushed. We might keep it around if we expect to be assigning new flocks to the snarf again, just to keep myOccupied. The snarfRecord will be recreated when another object is read in.'! (SnarfRecord getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; yourself)! !SnarfRecord methodsFor: 'writing'! {Int32} allocate: size {Int32} with: shep {Abraham} "Shep is being newly added to this snarf. Allocate enough space for it and return the newly assigned index for it." "The spaceLeft that we compute includes the size of the cells, otherwise we couldn't keep the number up to date." | index {IntegerVar} | size <= mySpaceLeft assert: 'Must have space left'. (shep isEqual: Pumpkin make) not assert: 'Only allocate real shepherds'. shep isStub not assert: 'Must be instantiated'. self thingToDo. "A hash check to see if shep is being forwarded back to this snarf from elsewhere." index _ self allocateIndex. shep getInfo setSize: size - SnarfHandler mapCellOverhead. self setSpaceLeft: mySpaceLeft - size. myChangedFlocks at: index store: shep. ^index DOTasLong! {void} changedFlock: index {Int32} with: shep {Abraham} "Remember that the flock at index must be written to the snarf on the next update." (shep isEqual: Pumpkin make) not assert: 'Record changes for real objects only'. "We don't return the flock's space to the pool here because it might be a forwarded flock." (Heaper isDestructed: shep) not assert: 'Must not be destructed'. shep isStub not assert: 'Must be instantiated'. myChangedFlocks at: index store: shep! {void} dismantleFlock: info {FlockInfo} "Remove the flock from the disk. Replace it with a Pumpkin so that the routine that flushes to disk knows to remove whatever's there already." "Remove the flocks space allocation now so that we can reallocate from the newly created pool." [|tmp {Abraham}| tmp _ myChangedFlocks fetch: info index. (tmp ~~ NULL and: [info fetchShepherd ~~ tmp]) ifTrue: [self halt]] smalltalkOnly. self setSpaceLeft: mySpaceLeft + info oldSize. myChangedFlocks at: info index store: Pumpkin make. myDestroyCount _ myDestroyCount + 1! ! !SnarfRecord methodsFor: 'transactions'! {void} flushChanges "Rewrite all flocks that have changed in this snarf." | highest {Int32} handler {SnarfHandler} newHighest {IntegerVar} stepper {PrimPtrTableStepper} shep {Abraham} | handler _ self getWriteHandler. highest _ handler mapCount. newHighest _ self wipeBelowHighest: highest with: handler. "mySpaceLeft also has the size of the cells taken out of it." self thingToDo. "Depending on tests, this might also preclear the total space for all of the flocks to be written. Then we will only compact once, and do it before writing any flocks." self hack. "This should get the highest index from myOccupied, except that it might not be computed." handler allocateCells: newHighest - highest. stepper := myChangedFlocks stepper. [(shep := stepper fetch cast: Abraham) ~~ NULL] whileTrue: [| index {IntegerVar} | index := stepper index. (shep isEqual: Pumpkin make) ifFalse: [shep getInfo snarfID == mySnarfID ifTrue: ["Not forwarded." | xmtr {Xmtr} stream {XnWriteStream} | shep isStub not assert: 'Must be instantiated'. handler at: index allocate: shep getInfo oldSize. stream _ handler writeStream: index. xmtr _ myPacker makeXmtr: stream. xmtr sendHeaper: shep. xmtr destroy. stream destroy. handler at: index DOTasLong storeForget: shep getInfo isForgotten. shep getInfo commitFlags. shep getInfo clearContentsDirty] ifFalse: ["We only get here for forwarded flocks." handler forward: index to: shep getInfo snarfID with: shep getInfo index]]. stepper step]. stepper destroy. myChangedFlocks clearAll. handler destroy! {void} refitFlocks "Recompute size information for all changed shepherds and see if they still fit. Any that don't get handed to the SnarfPacker to treat as new flocks. The old space changed and dismantled flocks has been returned to the pool. Reallocate space for the changed flocks out of the pool. Any that don't fit are handed back to myPacker to go in other snarfs." myChangedFlocks stepper forEach: [:shep {Abraham} | self setSpaceLeft: mySpaceLeft + shep getInfo oldSize. mySpaceLeft >= Int32Zero assert: 'Must have space left']. myChangedFlocks stepper forEach: [:shep {Abraham} | "Leave Pumpkins here so they will be seen by flushChanges." (shep isEqual: Pumpkin make) not ifTrue: [| size {Int32} | size _ myPacker computeSize: shep. shep getInfo setSize: size. size <= mySpaceLeft ifTrue: [self setSpaceLeft: mySpaceLeft - size] ifFalse: [myPacker forwardFlock: shep]]. mySpaceLeft >= Int32Zero assert: 'Must have space left'.]! {Int32} spaceLeft "Return the amount of space currently left in the snarf." ^mySpaceLeft! ! !SnarfRecord methodsFor: 'protected: destruct'! {void} destruct "Destroy all objects imaged from this snarf." myChangedFlocks destroy. myOccupied ~~ NULL ifTrue: [myOccupied destroy]. super destruct.! ! !SnarfRecord methodsFor: 'private: private'! {IntegerVar} allocateIndex "Return the first unoccupied index in the snarf. Compute the lowest element >= 0 that is not already in the occupied region by subtracting the occupied region from the region >= 0." | index {IntegerVar} | self readOccupied. index _ myOccupied nearestIntHole: IntegerVar0. myOccupied _ (myOccupied withInt: index) cast: IntegerRegion. ^index! {SnarfHandler} getWriteHandler "Get the handler for my snarf so that I can send or receive data from it." | handler {SnarfHandler} flag {BooleanVar} | flag := myOccupied ~~ NULL and: [myOccupied count == myChangedFlocks count]. "We also need to compare regions in case as many things are dismantled as are unchanged." "Change this to iterate myOCcupied and check the presence of each element. Either that or use an IntegerTable for myChangedFlocks." "myChangedFlocks really wants to be an optimizing representation." flag ifTrue: [ | stepper {PrimPtrTableStepper} | "calculate myOccupied isSuperSetOf: myChangedFlocks domain" stepper := myChangedFlocks stepper. [flag and: [stepper hasValue]] whileTrue: [ (myOccupied hasIntMember: stepper index) ifFalse: [flag := false]. stepper step]. flag := flag and: [stepper hasValue not]. stepper destroy]. flag ifTrue: [handler _ SnarfHandler make: (myPacker currentView makeErasingHandle: mySnarfID). handler initializeSnarf] ifFalse: [handler _ SnarfHandler make: (myPacker currentView makeReadHandle: mySnarfID)]. handler makeWritable. ^handler! {void} readOccupied "Create an array with the sizes of every flock in the snarf." | handler {SnarfHandler} count {Int32} | myOccupied ~~ NULL ifTrue: [^VOID]. mySpaceLeft >= (myPacker currentView getDataSizeOfSnarf: mySnarfID) ifTrue: [myOccupied _ IntegerRegion make. ^VOID]. handler _ SnarfHandler make: (myPacker currentView makeReadHandle: mySnarfID). count _ handler mapCount. myOccupied _ IntegerRegion make: IntegerVar0 with: count. Int32Zero almostTo: count do: [:i {Int32} | | shep {Abraham | NULL} | shep _ (myChangedFlocks fetch: i) cast: Abraham. ((handler isOccupied: i) not or: [shep ~~ NULL and: [shep isEqual: Pumpkin make]]) ifTrue: [myOccupied _ (myOccupied without: i integer) cast: IntegerRegion]]. handler destroy! {void} setSpaceLeft: spaceLeft {Int32} spaceLeft >= Int32Zero assert: 'Space is positive'. mySpaceLeft _ spaceLeft.! {IntegerVar} wipeBelowHighest: highest {Int32} with: handler {SnarfHandler} | newHighest {IntegerVar} stepper {PrimPtrTableStepper} | "(myChangedFlocks domain intersect: (IntegerRegion before: highest)) stepper forEach: [:key {XnInteger} | handler wipeFlock: key asIntegerVar]. ---- too inefficient. also compute the upper bound for later." newHighest _ highest. stepper _ myChangedFlocks stepper. [stepper hasValue] whileTrue: [| index {IntegerVar} | index := stepper index. index < highest ifTrue: [handler wipeFlock: index]. index >= newHighest ifTrue: [newHighest _ index+1 "Must be above the new key."]. stepper step]. stepper destroy. ^ newHighest! ! !SnarfRecord methodsFor: 'create'! create: snarfID {SnarfID} with: packer {SnarfPacker} with: spaceLeft {Int32} super create. mySnarfID _ snarfID. myPacker _ packer. myChangedFlocks _ PrimPtrTable make: 128. self setSpaceLeft: spaceLeft. myOccupied _ NULL. mySpaceLeft >= (myPacker currentView getDataSizeOfSnarf: mySnarfID) ifTrue: [mySpaceLeft _ (myPacker currentView getDataSizeOfSnarf: mySnarfID) - SnarfHandler mapOverhead. myOccupied _ IntegerRegion make]. myDestroyCount _ Int32Zero! ! !SnarfRecord methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '(' << mySnarfID << ')'! ! !SnarfRecord methodsFor: 'smalltalk: passe'! {FlockLocation} fetchForward: index {Int32} "If the location specified by info has been forwarded, return a flockInfo describing its new location." self passe! {MuSet of: IntegerPos} forgottenFlocks "Return the set of indices to locations that are forgotten." self passe! {BooleanVar} isForgotten: index {Int32} "Return true if the flock at that location is forgotten. Higher level routines should make sure this doesn't get done very often because it requires bringing in the snarf if it's not already there." self passe! {BooleanVar} isPurgeable "Return true if everything in this snarfRecord is purged. If so, then this snarfRecord can be thrown away." self passe! {void} makeReal: index {Int32} with: stub {Abraham} "We know that the object wasn't imaged. Read the real shepherd into the memory occupied by stub. If the location is a forwarder, then register a new flockInfo with the stub and just return." | handler {SnarfHandler} loc {FlockLocation | NULL} | stub isStub assert: 'Only stubs can be made real'. handler _ self getReadHandler. self readOccupied. loc _ handler fetchForward: index. loc == NULL ifTrue: [| info {FlockInfo} oldHash {UInt32} | info _ stub getInfo. oldHash _ stub hashForEqual. (myPacker makeRcvr: (handler readStream: index) with: mySnarfID with: index) receiveInto: stub. stub hashForEqual == oldHash assert: 'Hash must not change'. info setSize: (handler flockSize: index). stub flockInfo: info] ifFalse: ["Forwarded. Register stub at the new location." stub flockInfo: (FlockInfo make: stub getInfo with: loc snarfID with: loc index). myPacker addInfo: stub getInfo with: stub]. self releaseReadHandler! {Abraham} originateFlock: index {IntegerVar} "This will get a flock that we know the location of without a stub. The flock must not already be imaged, and it must not be forwarded." | result {Abraham} rcvr {Rcvr} | rcvr _ myPacker makeRcvr: (self getReadHandler readStream: index DOTasLong) with: mySnarfID with: index. result _ rcvr receiveHeaper cast: Abraham. self readOccupied. self releaseReadHandler. ^result! ! !SnarfRecord methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! SnarfRecord class instanceVariableNames: ''! (SnarfRecord getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; yourself)! !SnarfRecord class methodsFor: 'pcreate'! make: snarfID {SnarfID} with: packer {SnarfPacker} with: spaceLeft {Int32} ^self create: snarfID with: packer with: spaceLeft! !Heaper subclass: #SpecialistRcvrJig instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-snfinfo'! SpecialistRcvrJig comment: 'A tool to read partial packets from the disk to measure statistics.'! (SpecialistRcvrJig getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !SpecialistRcvrJig methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! SpecialistRcvrJig class instanceVariableNames: ''! (SpecialistRcvrJig getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !SpecialistRcvrJig class methodsFor: 'receiving'! {Category} receiveCategory: rcvr {Rcvr} ^ (rcvr cast: SpecialistRcvr) fetchStartOfInstance.! !Heaper subclass: #StackExaminer instanceVariableNames: '' classVariableNames: ' StackEnd {Int32 star} TheStackSet {PrimPtrTable} ' poolDictionaries: '' category: 'Xanadu-stacker'! StackExaminer comment: 'main() routines that are going to invoke garbage collection should call StackExaminer::stackEnd(&stackObj), where stackObj is an Int32 local to main''s stack frame. This should be called before anything else, even invoking the Initializer object.'! (StackExaminer getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !StackExaminer methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! StackExaminer class instanceVariableNames: ''! (StackExaminer getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !StackExaminer class methodsFor: 'accessing'! {PrimPtrTable} pointersOnStack "Do NOT destroy the result table. It is reused to avoid allocation during purgeClean." | result {PrimPtrTable} | TheStackSet == NULL ifTrue: [TheStackSet := PrimPtrTable make: 1024]. result _ TheStackSet. result clearAll. [| context | context _ thisContext. [context ~~ nil] whileTrue: [ context stack do: [:p | (p == nil or: [p isInteger]) ifFalse: [ result at: p asOop store: result ] ]. result at: context receiver store: result]. ] smalltalkOnly. 'Int32 stack; Int32 * stackPtr = & stack; if (StackExaminer::stackEnd() == NULL) { BLAST(StackEndUninitialized); } for (; stackPtr < (Int32 *) StackExaminer::stackEnd(); stackPtr++) { if (*stackPtr !!= 0 && (*stackPtr & 3) == 0) { result->store((Int32)(void*)*stackPtr, result); } }' translateOnly. ^ result! {Int32 star INLINE} stackEnd ^ StackEnd! {void} stackEnd: end {Int32 star} StackEnd _ end! ! !StackExaminer class methodsFor: 'smalltalk: init'! linkTimeNonInherited StackEnd := NULL. TheStackSet := NULL.! !XnExecutor subclass: #StatusDetectorExecutor instanceVariableNames: 'myWork {FeWork}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-nkernel'! StatusDetectorExecutor comment: 'This class informs its work when its last status detector has gone away.'! (StatusDetectorExecutor getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !StatusDetectorExecutor methodsFor: 'executing'! {void} execute: arg {Int32} arg == Int32Zero ifTrue: [ myWork removeLastStatusDetector]! ! !StatusDetectorExecutor methodsFor: 'protected: create'! create: work {FeWork} super create. myWork := work.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! StatusDetectorExecutor class instanceVariableNames: ''! (StatusDetectorExecutor getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !StatusDetectorExecutor class methodsFor: 'create'! {XnExecutor} make: work {FeWork} ^ self create: work! !Heaper subclass: #Stepper instanceVariableNames: '' classVariableNames: 'TheEmptyStepper {Stepper wimpy} ' poolDictionaries: '' category: 'Xanadu-Collection-Steppers'! Stepper comment: 'Steppers provide a common way to enumerate the elements of any abstraction which acts as a collection. This simplifies the protocols of the various collection classes, as they now merely have to provide messages to create the appropriate steppers, which then handle the rest of the job. Also, the Stepper steps over the set of elements which existed *at the time* the stepper was returned. If you''re stepping over the elements of a changable collection, and the elements are changing while you are stepping, any other rule could lead to confusion. Smalltalk''s collections provide the protocol to enumerate their elements directly. Having the collection change during stepping is the source of a famous Smalltalk bug. Clu and Alphard both have "Iterators" which are much like our Steppers, but these other languages both specify (as a pre-condition) that the collection not be changed while the Iterator is active. This burdens the programmer with ensuring a non-local property that we know of know way of robustly checking for in real programs. Steppers and Accumulators are sort of duals. Steppers are typically used in loops as a source of values to be consumed by the loop body. Accumulators are typically used as a sink for values which are produced in the loop body. One can (and sometimes does) interact with a Stepper explicitly through its protocol. However, for the typical case of just executing a loop body in turn for each successive element should be written using the FOR_EACH macro. The syntax of the macro is: FOR_EACH(ElementType,varName, (stepperValuedExpr), { Loop body (varName is in scope) }); For example: FOR_EACH(Position,each,(reg->stepper()), { doSomethingWith (each); }); is roughly equivalent to (see macro definition for exact equivalence): for(SPTR(Stepper) stomp = reg->stepper(); stomp->hasValue(); stomp->step()) { SPTR(Position) each = CAST(Position,stomp->fetch()); doSomethingWith (each); } stomp->destroy(); Since the Stepper is necessarily exhausted if we fall out the end of a FOR_EACH, and there isn''t anything useful we can do with an exhausted stepper, it''s no great loss for FOR_EACH to destroy it. Doing so substantially unburdens the garbage collector. In addition, the means we are planning to use to lower the overhead of having the Stepper step over a snapshot of the collection depends on (for its efficiency) the Stepper being destroyed promptly if it is dropped without stepping it to exhaustion. Not all Steppers will eventually terminate. For example, a Stepper which enumerates all the primes is perfectly reasonable. When using Steppers (and especially FOR_EACH), you should be confident that you haven''t just introduced an infinite loop into your program. See Stepper::hasValue(). It is normally considered bad style for two methods/functions to be pointing at the same Stepper. As long as Steppers 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 Stepper can be passed instead of a pointer to the same one, this is to be prefered. See Accumulator. Subclasses of Stepper can provide more protocol. See TableStepper.'! (Stepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; add: #EQ; yourself)! !Stepper methodsFor: 'create'! {Stepper CLIENT} copy "Return a new stepper which steps independently of me, but whose current value is the same as mine, and which must produce a future history of values which satisfies the same obligation that my contract obligates me to produce now. Typically, this will mean that he must produce the same future history that I'm going to produce. However, let's say that I am enumerating the elements of a partial order in some full order which is consistent with the partial order. If a copy of me is made after I'm part way through, then me and my copy may produce any future history compatable both with the partial order and the elements I've already produced by the time of the copy. Of course, a subclass or a Stepper creating message (like IntegerRegion::stepper()) may specify the more stringent requirement (that a copy must produce the same sequence). To prevent aliasing, Steppers should typically be passed by copy. See class comment." self subclassResponsibility! ! !Stepper methodsFor: 'operations'! {BooleanVar CLIENT} atEnd "Iff I have a current value (i.e. this message returns FALSE), then I am not exhasted. 'fetch' and 'get' will both return this value, and I can be 'step'ped to my next state. As I am stepped, eventually I may become exhausted (the reverse of all the above), which is a permanent condition. Note that not all steppers have to be exhaustable. A Stepper which enumerates all primes is perfectly reasonable. Assuming otherwise will create infinite loops. See class comment." ^self hasValue not! {Heaper wimpy} fetch "If I am exhausted (i.e., if (!! this->hasValue())), then return NULL. Else return current element. I return wimpily since most items returned are held by collections. If I create a new object, I should cache it." self subclassResponsibility! {Heaper wimpy CLIENT} get "Essential. BLAST if exhasted. Else return current element. I return wimpily since most items returned are held by collections. If I create a new object, I should cache it." | val {Heaper} | val _ self fetch. val == NULL ifTrue: [Heaper BLAST: #EmptyStepper]. ^val! {BooleanVar} hasValue "Iff I have a current value (i.e. this message returns true), then I am not exhasted. 'fetch' and 'get' will both return this value, and I can be 'step'ped to my next state. As I am stepped, eventually I may become exhausted (the reverse of all the above), which is a permanent condition. Note that not all steppers have to be exhaustable. A Stepper which enumerates all primes is perfectly reasonable. Assuming otherwise will create infinite loops. See class comment." self subclassResponsibility! {void CLIENT} step "Essential. If I am currently exhausted (see Stepper::hasValue()), then it is an error to step me. The result of doing so isn't currently specified (we probably should specify it to BLAST, but I know that the implementation doesn't currently live up to that spec). If I am not exhausted, then this advances me to my next state. If my current value (see Stepper::get()) was my final value, then I am now exhausted, otherwise my new current value is the next value." self subclassResponsibility! {PrimArray CLIENT} stepMany: count {Int32 default: -1} "Collects the remaining elements in the stepper into an array. Returns an array of no more than count elements (or some arbitrary chunk if the count is negative). The fact that you got fewer elements that you asked for does not mean that the stepper is atEnd, since there may be some reason to break the result up into smaller chunks; you should always check." | result {Accumulator} n {Int32} | count >= Int32Zero ifTrue: [n := count] ifFalse: [n := 1000]. result := PtrArrayAccumulator create: n. n := Int32Zero. [self hasValue and: [(count < Int32Zero and: [n < 1000]) or: [n < count]]] whileTrue: [result step: self fetch. self step. n := n + 1]. ^result value cast: PrimArray! {Heaper CLIENT} theOne "If there is precisely one element in the stepper return it; if not, blast without changing the state of the Stepper" | other {Stepper} result {Heaper} | self hasValue ifFalse: [Heaper BLAST: #MustHaveOneValue]. other := self copy. result := other fetch. other step. other hasValue ifTrue: [Heaper BLAST: #MustHaveOneValue]. ^result! ! !Stepper methodsFor: 'smalltalk: operations'! {void} forEach: fn {BlockClosure} [| elem {Heaper} | [(elem _ self fetch) ~~ NULL] whileTrue: [fn value: elem. self step]] valueNowOrOnUnwindDo: [self destroy]! ! !Stepper methodsFor: 'smalltalk: defaults'! {PrimArray CLIENT} stepMany ^self stepMany: -1! ! !Stepper methodsFor: 'smalltalk: passe'! {PrimArray} asArray: count {Int32 default: -1} self passe "stepMany"! ! !Stepper methodsFor: 'smalltalk: delayed iteration'! {void} forEachPromise: aBlock self knownBug. "only works outside of a delay block" [self atEnd value] whileFalse: [aBlock value: (XuPromise dynamicType: self get). self step]! ! !Stepper methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Stepper class instanceVariableNames: ''! (Stepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; add: #EQ; yourself)! !Stepper class methodsFor: 'pseudo constructors'! {Stepper INLINE} emptyStepper "A Stepper which is born exhausted. Useful for implementing empty collections" ^ TheEmptyStepper! {Stepper} itemStepper: item {Heaper} "A Stepper which will enumerate only this one element. Useful for implementing singleton collections." item == NULL ifTrue: [ ^ TheEmptyStepper ] ifFalse: [ ^ItemStepper make: item]! ! !Stepper class methodsFor: 'smalltalk: init'! initTimeNonInherited TheEmptyStepper := (EmptyStepper new.AllocType: #PERSISTENT) create! linkTimeNonInherited TheEmptyStepper := NULL! ! !Stepper class methodsFor: 'smalltalk: system'! info.stProtocol "{BooleanVar CLIENT} atEnd {Heaper wimpy CLIENT} get {void CLIENT} step {PrimArray CLIENT} stepMany: count {Int32 default: -1} {Heaper CLIENT} theOne "! !Stepper subclass: #AscendingIntegerStepper instanceVariableNames: ' myEdges {IntegerVarArray} myIndex {UInt32} myCount {UInt32} myPosition {IntegerVar}' classVariableNames: 'SomeSteppers {InstanceCache} ' poolDictionaries: '' category: 'Xanadu-Spaces-Integers'! (AscendingIntegerStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !AscendingIntegerStepper methodsFor: 'protected: creation'! create: edges {IntegerVarArray} with: count {UInt32} super create. myEdges _ edges. myIndex _ 1. myCount _ count. myCount > Int32Zero ifTrue: [myPosition _ myEdges integerVarAt: Int32Zero] ifFalse: [myPosition _ IntegerVar0]! create: edges {IntegerVarArray} with: index {UInt32} with: count {UInt32} with: position {IntegerVar} super create. myEdges _ edges. myIndex _ index. myCount _ count. myPosition _ position! ! !AscendingIntegerStepper methodsFor: 'creation'! {Stepper} copy | result {Heaper} | result := SomeSteppers fetch. result == NULL ifTrue: [^AscendingIntegerStepper create: myEdges with: myIndex with: myCount with: myPosition] ifFalse:[^(AscendingIntegerStepper new.Become: result) create: myEdges with: myIndex with: myCount with: myPosition]! {void} destroy (SomeSteppers store: self) ifFalse: [super destroy]! ! !AscendingIntegerStepper methodsFor: 'accessing'! {Heaper wimpy} fetch self hasValue ifTrue: [^myPosition integer] ifFalse: [^NULL]! {BooleanVar} hasValue ^myIndex <= myCount! {void} step myPosition _ myPosition + 1. (myIndex < myCount and: [myPosition = (myEdges integerVarAt: myIndex)]) ifTrue: [myIndex _ myIndex + 2. myIndex <= myCount ifTrue: [myPosition _ myEdges integerVarAt: myIndex - 1]]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AscendingIntegerStepper class instanceVariableNames: ''! (AscendingIntegerStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !AscendingIntegerStepper class methodsFor: 'smalltalk: init'! initTimeNonInherited SomeSteppers := InstanceCache make: 16! linkTimeNonInherited SomeSteppers := NULL! ! !AscendingIntegerStepper class methodsFor: 'creation'! {Stepper} make: edges {IntegerVarArray} with: count {UInt32} | result {Heaper} | result := SomeSteppers fetch. result == NULL ifTrue: [^ self create: edges with: count] ifFalse: [^ (self new.Become: result) create: edges with: count]! !Stepper subclass: #BoxProjectionStepper instanceVariableNames: ' myRegion {GenericCrossRegion} myBoxIndex {Int32} myBoxLimit {Int32} myDimension {Int32}' classVariableNames: 'SomeSteppers {InstanceCache} ' poolDictionaries: '' category: 'Xanadu-Spaces-Cross'! BoxProjectionStepper comment: 'Steps over all projections of some boxes. was not.a.type but this prevented compilation'! (BoxProjectionStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !BoxProjectionStepper methodsFor: 'create'! {Stepper} copy "Return a new stepper which steps independently of me, but whose current value is the same as mine, and which must produce a future history of values which satisfies the same obligation that my contract obligates me to produce now. Typically, this will mean that he must produce the same future history that I'm going to produce. However, let's say that I am enumerating the elements of a partial order in some full order which is consistent with the partial order. If a copy of me is made after I'm part way through, then me and my copy may produce any future history compatable both with the partial order and the elements I've already produced by the time of the copy. Of course, a subclass or a Stepper creating message (like IntegerRegion::stepper()) may specify the more stringent requirement (that a copy must produce the same sequence). To prevent aliasing, Steppers should typically be passed by copy. See class comment." Someone shouldImplement. ^NULL "fodder"! {void} destroy (SomeSteppers store: self) ifFalse: [super destroy]! ! !BoxProjectionStepper methodsFor: 'protected: create'! create: region {GenericCrossRegion} super create. myRegion := region. myBoxIndex := Int32Zero. myBoxLimit := region boxCount. myDimension := Int32Zero.! create: region {GenericCrossRegion} with: boxIndex {Int32} with: boxLimit {Int32} super create. myRegion := region. myBoxIndex := boxIndex. myBoxLimit := boxLimit. myDimension := Int32Zero.! create: region {GenericCrossRegion} with: boxIndex {Int32} with: boxLimit {Int32} with: dimension {Int32} super create. myRegion := region. myBoxIndex := boxIndex. myBoxLimit := boxLimit. myDimension := dimension.! ! !BoxProjectionStepper methodsFor: 'operations'! {Heaper wimpy} fetch myBoxIndex < myBoxLimit ifFalse: [^NULL]. ^self projection! {BooleanVar} hasValue ^myBoxIndex < myBoxLimit! {void} step myBoxIndex < myBoxLimit ifTrue: [myDimension := myDimension + 1. myDimension < myRegion crossSpace axisCount ifFalse: [myBoxIndex := myBoxIndex + 1. myDimension := Int32Zero]].! ! !BoxProjectionStepper methodsFor: 'accessing'! {Int32} dimension ^myDimension! {XnRegion} projection ^myRegion boxProjection: myBoxIndex with: myDimension! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BoxProjectionStepper class instanceVariableNames: ''! (BoxProjectionStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !BoxProjectionStepper class methodsFor: 'create'! make: region {GenericCrossRegion} | result {Heaper} | result := SomeSteppers fetch. result == NULL ifTrue: [^ self create: region] ifFalse: [^ (self new.Become: result) create: region]! make: region {GenericCrossRegion} with: boxIndex {Int32} with: boxLimit {Int32} | result {Heaper} | result := SomeSteppers fetch. result == NULL ifTrue: [^ self create: region with: boxIndex with: boxLimit] ifFalse: [^ (self new.Become: result) create: region with: boxIndex with: boxLimit]! ! !BoxProjectionStepper class methodsFor: 'smalltalk: init'! initTimeNonInherited SomeSteppers := InstanceCache make: 8! linkTimeNonInherited SomeSteppers := NULL! !Stepper subclass: #BoxStepper instanceVariableNames: ' myRegion {GenericCrossRegion} myIndex {Int32} myValue {XnRegion | NULL}' classVariableNames: 'SomeSteppers {InstanceCache} ' poolDictionaries: '' category: 'Xanadu-Spaces-Cross'! BoxStepper comment: 'Steps over all boxes. was NOT.A.TYPE but this prevented compilation'! (BoxStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !BoxStepper methodsFor: 'operations'! {Heaper wimpy} fetch myIndex >= myRegion boxCount ifTrue: [^NULL]. myValue == NULL ifTrue: [myValue := GenericCrossRegion make: myRegion crossSpace with: 1 with: ((myRegion secretRegions copy: myRegion crossSpace axisCount with: myIndex * myRegion crossSpace axisCount) cast: PtrArray)]. ^myValue! {BooleanVar} hasValue ^myIndex < myRegion boxCount! {void} step myIndex < myRegion boxCount ifTrue: [myIndex := myIndex + 1. myValue := NULL]! ! !BoxStepper methodsFor: 'create'! {Stepper} copy | result {Heaper} | result := SomeSteppers fetch. result == NULL ifTrue: [^BoxStepper create: myRegion with: myIndex with: myValue] ifFalse: [^(BoxStepper new.Become: result) create: myRegion with: myIndex with: myValue]! {void} destroy (SomeSteppers store: self) ifFalse: [super destroy]! ! !BoxStepper methodsFor: 'protected: create'! create: region {GenericCrossRegion} super create. myRegion := region. myIndex := Int32Zero. myValue := NULL.! create: region {GenericCrossRegion} with: index {Int32} with: value {XnRegion | NULL} super create. myRegion := region. myIndex := index. myValue := value.! ! !BoxStepper methodsFor: 'accessing'! {GenericCrossRegion} boxComplement "The complement of this box" | result {BoxAccumulator} extrusion {PtrArray of: XnRegion} | result := BoxAccumulator make: myRegion crossSpace with: myRegion crossSpace axisCount. Int32Zero almostTo: myRegion crossSpace axisCount do: [ :dimension {Int32} | | special {XnRegion} | extrusion := PtrArray nulls: myRegion crossSpace axisCount. Int32Zero almostTo: dimension do: [ :i {Int32} | extrusion at: i store: (self projection: i)]. special := (self projection: dimension) complement. special isEmpty ifFalse: [extrusion at: dimension store: special. dimension + 1 almostTo: myRegion crossSpace axisCount do: [ :i {Int32} | extrusion at: i store: (myRegion crossSpace axis: i) fullRegion]. result addProjections: extrusion with: Int32Zero]]. ^result region cast: GenericCrossRegion! {BoxAccumulator} boxComplementAccumulator "The complement of this box" | result {BoxAccumulator} extrusion {PtrArray of: XnRegion} | result := BoxAccumulator make: myRegion crossSpace with: myRegion crossSpace axisCount. Int32Zero almostTo: myRegion crossSpace axisCount do: [ :dimension {Int32} | extrusion := PtrArray nulls: myRegion crossSpace axisCount. Int32Zero almostTo: dimension do: [ :i {Int32} | extrusion at: i store: (self projection: i)]. extrusion at: dimension store: (self projection: dimension) complement. dimension + 1 almostTo: myRegion crossSpace axisCount do: [ :i {Int32} | extrusion at: i store: (myRegion crossSpace axis: i) fullRegion]. result addProjections: extrusion with: Int32Zero]. ^result! {UInt32} boxHash | result {UInt32} | result := UInt32Zero. self projectionStepper forEach: [ :sub {XnRegion} | result := result bitXor: sub hashForEqual]. ^result! {BooleanVar} boxHasMember: tuple {ActualTuple} "Whether my current box contains a position" | mine {BoxProjectionStepper} | mine := self projectionStepper. [mine hasValue] whileTrue: [(mine projection hasMember: (tuple positionAt: mine dimension)) ifFalse: [^false]. mine step]. mine destroy. ^true! {Int32} boxIndex ^myIndex! {BooleanVar} boxIntersects: other {BoxStepper} "Whether my current box intersects others current box" | mine {BoxProjectionStepper} others {BoxProjectionStepper} | mine := self projectionStepper. others := other projectionStepper. [mine hasValue] whileTrue: [(mine projection intersects: others projection) ifFalse: [^false]. mine step. others step]. mine destroy. others destroy. ^true! {BooleanVar} boxIsEqual: other {BoxStepper} "Whether my current box isEqual others current box" | mine {BoxProjectionStepper} others {BoxProjectionStepper} | mine := self projectionStepper. others := other projectionStepper. [mine hasValue] whileTrue: [(mine projection isEqual: others projection) ifFalse: [^false]. mine step. others step]. mine destroy. others destroy. ^true! {BooleanVar} boxIsSubsetOf: other {BoxStepper} "Whether my current box isSubsetOf others current box" | mine {BoxProjectionStepper} others {BoxProjectionStepper} | mine := self projectionStepper. others := other projectionStepper. [mine hasValue] whileTrue: [(mine projection isSubsetOf: others projection) ifFalse: [^false]. mine step. others step]. mine destroy. others destroy. ^true! {BooleanVar} intersectBoxInto: result {PtrArray of: XnRegion} with: boxIndex {Int32} "Intersect each projection in the box into the array. Return false if the result is empty, stopping at the first dimension for which the intersection is empty." | mine {BoxProjectionStepper} proj {XnRegion} base {Int32} | base := myRegion crossSpace axisCount * boxIndex. mine := self projectionStepper. [mine hasValue] whileTrue: [result at: base + mine dimension store: (proj := ((result fetch: base + mine dimension) cast: XnRegion) intersect: mine projection). proj isEmpty ifTrue: [^false]. mine step]. mine destroy. ^true! {BooleanVar} isBoxOf: other {GenericCrossRegion} "Whether my box is also a box in the other region" | others {BoxStepper} | others := other boxStepper. [others hasValue] whileTrue: [(self boxIsEqual: others) ifTrue: [^true]. others step]. ^false! {XnRegion} projection: dimension {Int32} "The projection of my current box into one dimension" ^myRegion boxProjection: myIndex with: dimension! {BoxProjectionStepper} projectionStepper "A stepper over all the projections in the current box" ^BoxProjectionStepper make: myRegion with: myIndex with: myIndex + 1! {GenericCrossRegion} region ^myRegion! {void} unionBoxInto: result {PtrArray of: XnRegion} with: boxIndex {Int32} "Union each projection in the box into the array" | mine {BoxProjectionStepper} base {Int32} | base := myRegion crossSpace axisCount * boxIndex. mine := self projectionStepper. [mine hasValue] whileTrue: [result at: base + mine dimension store: (((result fetch: base + mine dimension) cast: XnRegion) unionWith: mine projection). mine step]. mine destroy.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BoxStepper class instanceVariableNames: ''! (BoxStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !BoxStepper class methodsFor: 'smalltalk: init'! initTimeNonInherited SomeSteppers := InstanceCache make: 8! linkTimeNonInherited SomeSteppers := NULL! ! !BoxStepper class methodsFor: 'create'! make: region {GenericCrossRegion} | result {Heaper} | result := SomeSteppers fetch. result == NULL ifTrue: [^ self create: region] ifFalse: [^ (self new.Become: result) create: region]! !Stepper subclass: #DescendingIntegerStepper instanceVariableNames: ' myEdges {IntegerVarArray} myIndex {Int32} myPosition {IntegerVar}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Spaces-Integers'! (DescendingIntegerStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !DescendingIntegerStepper methodsFor: 'protected: create'! create: edges {IntegerVarArray} with: count {UInt32} super create. myEdges _ edges. myIndex _ count - 2. myIndex >= -1 ifTrue: [myPosition _ (myEdges integerVarAt: myIndex + 1) - 1] ifFalse: [myPosition _ IntegerVar0]! create: edges {IntegerVarArray} with: index {Int32} with: position {IntegerVar} super create. myEdges _ edges. myIndex _ index. myPosition _ position! ! !DescendingIntegerStepper methodsFor: 'creation'! {Stepper} copy ^DescendingIntegerStepper create: myEdges with: myIndex with: myPosition! ! !DescendingIntegerStepper methodsFor: 'accessing'! {Heaper wimpy} fetch self hasValue ifTrue: [^myPosition integer] ifFalse: [^NULL]! {BooleanVar} hasValue ^myIndex >= -1! {void} step myPosition _ myPosition - 1. (myIndex >= Int32Zero and: [myPosition < (myEdges integerVarAt: myIndex)]) ifTrue: [myIndex _ myIndex - 2. myIndex >= -1 ifTrue: [myPosition _ (myEdges integerVarAt: myIndex + 1) - 1]]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DescendingIntegerStepper class instanceVariableNames: ''! (DescendingIntegerStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !DescendingIntegerStepper class methodsFor: 'creation'! {Stepper} make: edges {IntegerVarArray} with: count {UInt32} ^ self create: edges with: count! !Stepper subclass: #DisjointRegionStepper instanceVariableNames: ' myValue {XnRegion} myRegion {XnRegion} myOrder {OrderSpec}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Steppers'! (DisjointRegionStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !DisjointRegionStepper methodsFor: 'accessing'! {Heaper wimpy} fetch ^myValue! {BooleanVar} hasValue ^myValue ~~ NULL! {void} step myValue _ (myRegion simpleRegions: myOrder) fetch cast: XnRegion. myValue == NULL ifTrue: [myRegion isEmpty ifFalse: [Heaper BLAST: #RegionReturnedNullStepperEvenThoughNonEmpty]] ifFalse: [myRegion _ myRegion minus: myValue]! ! !DisjointRegionStepper methodsFor: 'instance creation'! {Stepper} copy ^DisjointRegionStepper make: (myValue unionWith: myRegion) with: myOrder! create: region {XnRegion} with: order {OrderSpec} super create. myValue _ NULL. myRegion _ region. myOrder _ order. myRegion isEmpty ifFalse: [self step].! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DisjointRegionStepper class instanceVariableNames: ''! (DisjointRegionStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !DisjointRegionStepper class methodsFor: 'instance creation'! {Stepper} make: region {XnRegion} with: order {OrderSpec} ^DisjointRegionStepper create: region with: order! !Stepper subclass: #EdgeSimpleRegionStepper instanceVariableNames: ' myManager {EdgeManager} myEdges {EdgeStepper} mySimple {XnRegion}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-EdgeRegion'! EdgeSimpleRegionStepper comment: 'Consider this a "protected" class. See class comment in EdgeAccumulator'! (EdgeSimpleRegionStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !EdgeSimpleRegionStepper methodsFor: 'accessing'! {Heaper wimpy} fetch ^mySimple! {BooleanVar} hasValue ^mySimple ~~ NULL! {void} step | startsInside {BooleanVar} one {TransitionEdge} two {TransitionEdge} | "if there are no more edges then the stepper is empty remember whether we're entering or leaving the region fetch the first edge if there is no first edge then remember the edges are gone if we were already in the region then there is the full region else we're empty else there is a first edge, so if we start outside and there is another edge then get it and make a two-sided region else make a one-side region" myEdges == NULL ifTrue: [mySimple := NULL. ^VOID]. startsInside := myEdges isEntering not. one := myEdges fetchEdge. one == NULL ifTrue: [myEdges := NULL. (startsInside and: [mySimple == NULL]) ifTrue: [mySimple := myManager makeNew: true with: PtrArray empty] ifFalse: [mySimple := NULL]] ifFalse: [myEdges step. (startsInside not and: [myEdges hasValue]) ifTrue: [two := myEdges fetchEdge. myEdges step. mySimple := myManager makeNew: startsInside with: ((PrimSpec pointer arrayWithTwo: one with: two) cast: PtrArray)] ifFalse: [mySimple := myManager makeNew: startsInside with: ((PrimSpec pointer arrayWith: one) cast: PtrArray)]].! ! !EdgeSimpleRegionStepper methodsFor: 'create'! {Stepper} copy | step {EdgeStepper} | "can't to ?: with SPTRs" step := myEdges. step ~~ NULL ifTrue: [step := myEdges copy cast: EdgeStepper]. ^ EdgeSimpleRegionStepper create: myManager with: step with: mySimple! ! !EdgeSimpleRegionStepper methodsFor: 'protected: create'! create: manager {EdgeManager} with: edges {EdgeStepper} super create. myManager := manager. myEdges := edges. mySimple := NULL. self step.! create: manager {EdgeManager} with: edges {EdgeStepper | NULL} with: simple {XnRegion | NULL} super create. myManager := manager. myEdges := edges. mySimple := simple! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! EdgeSimpleRegionStepper class instanceVariableNames: ''! (EdgeSimpleRegionStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !EdgeSimpleRegionStepper class methodsFor: 'create'! make: manager {EdgeManager} with: edges {EdgeStepper} ^ self create: manager with: edges! !Stepper subclass: #EdgeStepper instanceVariableNames: ' myEntering {BooleanVar} myEdges {PtrArray of: TransitionEdge} myEdgesCount {Int32} myIndex {Int32}' classVariableNames: 'SomeEdgeSteppers {InstanceCache} ' poolDictionaries: '' category: 'Xanadu-EdgeRegion'! EdgeStepper comment: 'A single instance of this class is cached. To take advantage of this, a method that uses EdgeSteppers should explicitly destroy at least one of them. Consider this a "protected" class. See class comment in EdgeAccumulator.'! (EdgeStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !EdgeStepper methodsFor: 'accessing'! {Heaper wimpy} fetch myIndex < myEdgesCount ifTrue: [^myEdges fetch: myIndex] ifFalse: [^NULL]! {BooleanVar} hasValue ^myIndex < myEdgesCount! {void} step self hasValue ifTrue: [myEntering := myEntering not. myIndex := myIndex + 1]! ! !EdgeStepper methodsFor: 'edge accessing'! {TransitionEdge | NULL} fetchEdge myIndex < myEdgesCount ifTrue: [^(myEdges fetch: myIndex) cast: TransitionEdge] ifFalse: [^NULL]! {TransitionEdge} getEdge myIndex < myEdgesCount ifTrue: [^(myEdges fetch: myIndex) cast: TransitionEdge] ifFalse: [Heaper BLAST: #EmptyStepper]. ^NULL "fodder"! {BooleanVar} isEntering "whether the current transition is entering or leaving the set" ^myEntering! ! !EdgeStepper methodsFor: 'protected: create'! create: entering {BooleanVar} with: edges {PtrArray of: TransitionEdge} with: count {Int32} super create. myEntering := entering. myEdges := edges. myEdgesCount := count. myIndex := Int32Zero! create: entering {BooleanVar} with: edges {PtrArray of: TransitionEdge} with: count {Int32} with: index {Int32} super create. myEntering := entering. myEdges := edges. myEdgesCount := count. myIndex := index! ! !EdgeStepper methodsFor: 'create'! {Stepper} copy ^EdgeStepper create: myEntering with: myEdges with: myEdgesCount with: myIndex! ! !EdgeStepper methodsFor: 'destroy'! {void} destroy (SomeEdgeSteppers store: self) ifFalse: [super destroy]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! EdgeStepper class instanceVariableNames: ''! (EdgeStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !EdgeStepper class methodsFor: 'create'! make: entering {BooleanVar} with: edges {PtrArray of: TransitionEdge} | result {Heaper} | result := SomeEdgeSteppers fetch. result == NULL ifTrue: [ ^ self create: entering with: edges with: edges count] ifFalse: [ ^ (self new.Become: result) create: entering with: edges with: edges count]! make: entering {BooleanVar} with: edges {PtrArray of: TransitionEdge} with: count {Int32} | result {Heaper} | result := SomeEdgeSteppers fetch. result == NULL ifTrue: [ ^ self create: entering with: edges with: count] ifFalse: [ ^ (self new.Become: result) create: entering with: edges with: count]! ! !EdgeStepper class methodsFor: 'smalltalk: init'! initTimeNonInherited SomeEdgeSteppers := InstanceCache make: 16! linkTimeNonInherited SomeEdgeSteppers := NULL! !Stepper subclass: #EmptyStepper instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-stepper'! EmptyStepper comment: 'This is a Stepper when you just want to step across a single item.'! (EmptyStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !EmptyStepper methodsFor: 'protected: destruct'! {void} destruct "This object is a canonical single instance, so its destructor should only be called after main has exited." 'if (!!Initializer::inStaticDestruction()) BLAST(SanityViolation);' translateOnly. super destruct! ! !EmptyStepper methodsFor: 'create'! {Stepper} copy ^ self! {void} destroy "No"! ! !EmptyStepper methodsFor: 'operations'! {Heaper wimpy} fetch ^ NULL! {BooleanVar} hasValue ^ false! {void} step! !Stepper subclass: #GenericCrossSimpleRegionStepper instanceVariableNames: ' mySpace {CrossSpace} myBoxes {Stepper of: CrossRegion} mySimples {PtrArray of: (Stepper of: XnRegion)}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-cross'! (GenericCrossSimpleRegionStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; add: #NOT.A.TYPE; yourself)! !GenericCrossSimpleRegionStepper methodsFor: 'operations'! {Heaper wimpy} fetch | result {PtrArray} | self hasValue ifFalse: [^NULL]. result := PtrArray nulls: mySpace axisCount. Int32Zero almostTo: mySpace axisCount do: [ :i {Int32} | result at: i store: ((mySimples get: i) cast: Stepper) get]. ^mySpace crossOfRegions: result! {BooleanVar} hasValue ^myBoxes hasValue! {void} step | index {Int32} | myBoxes hasValue ifTrue: [ index := mySpace axisCount - 1. [index >= Int32Zero] whileTrue: [ | sub {Stepper} | sub := (mySimples get: index) cast: Stepper. sub step. sub hasValue ifTrue: [self replenishSteppers: index + 1. ^VOID]. index := index - 1]. myBoxes step. myBoxes hasValue ifTrue: [self replenishSteppers: Int32Zero]]! ! !GenericCrossSimpleRegionStepper methodsFor: 'private:'! {void} replenishSteppers: index {Int32} "Replenish all steppers starting at index" | box {CrossRegion} | box := myBoxes get cast: CrossRegion. index almostTo: mySpace axisCount do: [ :i {Int32} | mySimples at: i store: (box projection: i) simpleRegions]! ! !GenericCrossSimpleRegionStepper methodsFor: 'create'! {Stepper} copy | simples {PtrArray} | simples := PtrArray nulls: mySimples count. Int32Zero almostTo: simples count do: [ :i {Int32} | simples at: i store: ((mySimples get: i) cast: Stepper) copy]. ^GenericCrossSimpleRegionStepper create: mySpace with: myBoxes copy with: simples! ! !GenericCrossSimpleRegionStepper methodsFor: 'protected: create'! create: space {CrossSpace} with: boxes {Stepper} super create. mySpace := space. myBoxes := boxes. boxes hasValue ifTrue: [mySimples := PtrArray nulls: space axisCount. self replenishSteppers: Int32Zero]! create: space {CrossSpace} with: boxes {Stepper} with: simples {PtrArray} super create. mySpace := space. myBoxes := boxes. mySimples := simples.! ! !GenericCrossSimpleRegionStepper methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GenericCrossSimpleRegionStepper class instanceVariableNames: ''! (GenericCrossSimpleRegionStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; add: #NOT.A.TYPE; yourself)! !GenericCrossSimpleRegionStepper class methodsFor: 'create'! {Stepper} make: space {CrossSpace} with: boxes {Stepper} ^self create: space with: boxes! !Stepper subclass: #GrandDataPageStepper instanceVariableNames: ' page {GrandDataPage} entryIndex {IntegerVar}' classVariableNames: '' poolDictionaries: '' category: 'Cxx-class-stuff'! (GrandDataPageStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !GrandDataPageStepper methodsFor: 'operations'! {GrandEntry} entry ^ (page entryAt: entryIndex) basicCast: GrandEntry! {Heaper wimpy} fetch self shouldNotImplement. ^ NULL! {BooleanVar} hasValue ^ entryIndex < page entryCount! {void} step entryIndex _ entryIndex + 1. self verifyEntry! ! !GrandDataPageStepper methodsFor: 'private: create'! create: aPage {GrandDataPage} with: index {IntegerVar} super create. page _ aPage. entryIndex _ index. self verifyEntry.! ! !GrandDataPageStepper methodsFor: 'private: private'! {void} verifyEntry [entryIndex < page entryCount and: [(page entryAt: entryIndex) == NULL]] whileTrue: [entryIndex _ entryIndex + 1]! ! !GrandDataPageStepper methodsFor: 'create'! {Stepper} copy ^ GrandDataPageStepper create: page with: entryIndex! create: aPage {GrandDataPage} super create. page _ aPage. entryIndex _ IntegerVar0. self verifyEntry! !Stepper subclass: #GrandHashSetStepper instanceVariableNames: ' set {GrandHashSet} nodeStepper {GrandNodeStepper | NULL} nodeIndex {IntegerVar}' classVariableNames: '' poolDictionaries: '' category: 'Cxx-class-stuff'! (GrandHashSetStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !GrandHashSetStepper methodsFor: 'private: private'! {void} verifyEntry [nodeIndex < set nodeCount and: [(set nodeAt: nodeIndex) isEmpty]] whileTrue: [nodeIndex _ nodeIndex + 1 ]. nodeIndex < set nodeCount ifTrue: [nodeStepper _ GrandNodeStepper create: (set nodeAt: nodeIndex)]! ! !GrandHashSetStepper methodsFor: 'operations'! {Heaper wimpy} fetch (nodeStepper ~~ NULL and: [nodeStepper hasValue]) ifTrue: [^ nodeStepper entry value] ifFalse: [^ NULL]! {BooleanVar} hasValue ^ (nodeIndex < set nodeCount) and: [nodeStepper hasValue]! {void} step nodeStepper step. nodeStepper hasValue ifFalse: [nodeStepper destroy. nodeStepper _ NULL. nodeIndex _ nodeIndex + 1. self verifyEntry]! ! !GrandHashSetStepper methodsFor: 'protected: create'! create: aSet {GrandHashSet} with: aNodeStepper {GrandNodeStepper} with: aNodeIndex {IntegerVar} super create. set _ aSet. set moreSteppers. nodeStepper _ aNodeStepper. nodeIndex _ aNodeIndex.! {void} destruct nodeStepper ~~ NULL ifTrue: [ nodeStepper destroy ]. set fewerSteppers. super destruct.! ! !GrandHashSetStepper methodsFor: 'create'! {Stepper} copy ^ GrandHashSetStepper create: set with: nodeStepper with: nodeIndex! create: aSet {GrandHashSet} super create. set _ aSet. set moreSteppers. nodeIndex _ IntegerVar0. nodeStepper _ NULL. self verifyEntry! !Stepper subclass: #GrandNodeStepper instanceVariableNames: ' node {GrandNode} pageStepper {GrandDataPageStepper} pageIndex {IntegerVar} overflowStepper {GrandOverflowStepper}' classVariableNames: '' poolDictionaries: '' category: 'Cxx-class-stuff'! (GrandNodeStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !GrandNodeStepper methodsFor: 'protected: creation'! create: aNode {GrandNode} with: curPageStepper {GrandDataPageStepper} with: curPageIndex {IntegerVar} with: oflowStepper {GrandOverflowStepper} super create. node _ aNode. pageStepper _ curPageStepper. pageIndex _ curPageIndex. overflowStepper _ oflowStepper.! {void} destruct pageStepper ~~ NULL ifTrue: [ pageStepper destroy ]. overflowStepper ~~ NULL ifTrue: [ overflowStepper destroy ]. super destruct.! ! !GrandNodeStepper methodsFor: 'private:'! {void} verifyEntry [pageIndex < node pageCount and: [(node pageAt: pageIndex) isEmpty]] whileTrue: [pageIndex _ pageIndex + 1]. pageIndex < node pageCount ifTrue: [pageStepper _ GrandDataPageStepper create: (node pageAt: pageIndex)] ifFalse: [(overflowStepper == NULL and: [node fetchOverflow ~~ NULL]) ifTrue: [overflowStepper _ GrandOverflowStepper create: node fetchOverflow] ifFalse: [overflowStepper ~~ NULL ifTrue: [overflowStepper destroy]. overflowStepper _ NULL. node fetchOldOverflow ~~ NULL ifTrue: [overflowStepper _ GrandOverflowStepper create: node fetchOldOverflow]]]! ! !GrandNodeStepper methodsFor: 'operations'! {GrandEntry} entry overflowStepper ~~ NULL ifTrue: [ ^ overflowStepper entry ] ifFalse: [ ^ pageStepper entry ]! {Heaper wimpy} fetch self shouldNotImplement. ^ NULL! {BooleanVar} hasValue overflowStepper ~~ NULL ifTrue: [ ^ overflowStepper hasValue ] ifFalse: [ ^ pageStepper ~~ NULL and: [pageStepper hasValue] ]! {void} step overflowStepper ~~ NULL ifTrue: [ overflowStepper step ] ifFalse: [pageStepper step. pageStepper hasValue ifFalse: [pageStepper destroy. pageStepper _ NULL. pageIndex _ pageIndex + 1. self verifyEntry]]! ! !GrandNodeStepper methodsFor: 'create'! {Stepper} copy ^ GrandNodeStepper create: node with: pageStepper with: pageIndex with: overflowStepper! create: aNode {GrandNode} super create. node _ aNode. pageIndex _ IntegerVar0. pageStepper _ NULL. overflowStepper _ NULL. self verifyEntry.! !Stepper subclass: #GrandOverflowStepper instanceVariableNames: ' overflow {GrandOverflow} entryIndex {IntegerVar} childStepper {GrandOverflowStepper} childIndex {IntegerVar}' classVariableNames: '' poolDictionaries: '' category: 'Cxx-class-stuff'! (GrandOverflowStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !GrandOverflowStepper methodsFor: 'private:'! {void} verifyEntry entryIndex < overflow entryCount ifTrue: [[entryIndex < overflow entryCount and: [(overflow entryAt: entryIndex) == NULL]] whileTrue: [entryIndex _ entryIndex + 1]]. entryIndex < overflow entryCount ifTrue: [ ^ VOID ]. childIndex < overflow childCount ifTrue: [[childIndex < overflow childCount and: [(overflow childAt: childIndex) == NULL]] whileTrue: [childIndex _ childIndex + 1]. childIndex < overflow childCount ifTrue: [ childStepper _ GrandOverflowStepper create: (overflow childAt: childIndex) ]]! ! !GrandOverflowStepper methodsFor: 'operations'! {GrandEntry} entry childStepper == NULL ifTrue: [ ^ overflow entryAt: entryIndex ] ifFalse: [ ^ childStepper entry ]! {Heaper wimpy} fetch self shouldNotImplement. ^ NULL! {BooleanVar} hasValue childStepper ~~ NULL ifTrue: [ ^ childStepper hasValue ] ifFalse: [ ^ entryIndex < overflow entryCount and: [childIndex < overflow childCount]]! {void} step childStepper ~~ NULL ifTrue: [childStepper step. childStepper hasValue ifTrue: [ ^VOID ] ifFalse: [childStepper destroy. childStepper _ NULL. childIndex _ childIndex + 1]] ifFalse: [entryIndex _ entryIndex + 1]. self verifyEntry! ! !GrandOverflowStepper methodsFor: 'create'! {Stepper} copy ^ GrandOverflowStepper create: overflow with: entryIndex with: childStepper with: childIndex! create: aPage {GrandOverflow} super create. overflow _ aPage. entryIndex _ childIndex _ IntegerVar0. childStepper _ NULL. self verifyEntry.! ! !GrandOverflowStepper methodsFor: 'protected: creation'! create: anOverflow {GrandOverflow} with: entryIdx {IntegerVar} with: child {GrandOverflowStepper} with: childIdx {IntegerVar} super create. overflow _ anOverflow. entryIndex _ entryIdx. childStepper _ child. childIndex _ childIdx.! {void} destruct childStepper ~~ NULL ifTrue: [ childStepper destroy ]. super destruct.! !Stepper subclass: #HashSetStepper instanceVariableNames: ' myElements {SharedPtrArray} myCurrent {Int32}' classVariableNames: 'SomeSteppers {InstanceCache} ' poolDictionaries: '' category: 'Xanadu-Collection-Steppers'! (HashSetStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !HashSetStepper methodsFor: 'accessing'! {Heaper wimpy} fetch (myElements ~~ NULL and: [myCurrent < myElements count]) ifTrue: [^myElements fetch: myCurrent] ifFalse: [^NULL]! {BooleanVar} hasValue ^myElements ~~ NULL and: [myCurrent < myElements count]! {void} step myCurrent _ myCurrent + 1. self verifyEntry! ! !HashSetStepper methodsFor: 'protected: destruct'! {void} destruct myElements ~~ NULL ifTrue: [ myElements shareLess]. super destruct! ! !HashSetStepper methodsFor: 'protected: creation'! create: elements {SharedPtrArray} with: current {Int32} super create. myElements _ elements. myElements shareMore. myCurrent _ current. self verifyEntry! ! !HashSetStepper methodsFor: 'creation'! {Stepper} copy | result {Heaper} | result := SomeSteppers fetch. result == NULL ifTrue: [^ HashSetStepper create: myElements with: myCurrent] ifFalse: [^ (HashSetStepper new.Become: result) create: myElements with: myCurrent]! {void} destroy (SomeSteppers store: self) ifFalse: [super destroy]! ! !HashSetStepper methodsFor: 'private:'! {void} verifyEntry myElements ~~ NULL ifTrue: [ myCurrent < myElements count ifTrue: [ myCurrent := myElements indexPast: NULL with: myCurrent. myCurrent == -1 ifTrue: [myCurrent := myElements count]]. self hasValue ifFalse: [ myElements shareLess. myElements := NULL]].! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HashSetStepper class instanceVariableNames: ''! (HashSetStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !HashSetStepper class methodsFor: 'pseudo constructors'! {Stepper} make: elements {SharedPtrArray} | result {Heaper} | result := SomeSteppers fetch. result == NULL ifTrue: [^ self create: elements with: Int32Zero] ifFalse: [^ (self new.Become: result) create: elements with: Int32Zero]! ! !HashSetStepper class methodsFor: 'smalltalk: init'! initTimeNonInherited SomeSteppers := InstanceCache make: 16.! linkTimeNonInherited SomeSteppers := NULL! !Stepper subclass: #IDSimpleStepper instanceVariableNames: ' myRegion {IDRegion} myBackends {Stepper | NULL of: Sequence} myIDs {Stepper | NULL of: (XnRegion of: Integer)} myValue {IDRegion | NULL} myInexplicit {IDRegion | NULL}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-id'! (IDSimpleStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !IDSimpleStepper methodsFor: 'create'! {Stepper} copy ^IDSimpleStepper create: myRegion with: myBackends copy with: myIDs copy with: myInexplicit! create: region {IDRegion} super create. myRegion := region. myBackends := region explicitBackends stepper. myBackends hasValue ifTrue: [myIDs := (region iDNumbersFrom: (myBackends fetch cast: Sequence)) simpleRegions] ifFalse: [myIDs := NULL. myBackends := NULL]. myValue := NULL. myInexplicit := region fetchInexplicit! create: region {IDRegion} with: backends {Stepper of: Sequence} with: iDs {Stepper of: XnRegion} with: inexplicit {IDRegion | NULL} super create. myRegion := region. myBackends := backends. myIDs := iDs. myValue := NULL. myInexplicit := inexplicit.! ! !IDSimpleStepper methodsFor: 'operations'! {Heaper wimpy} fetch myInexplicit ~~ NULL ifTrue: [^myInexplicit]. (myValue == NULL and: [myBackends ~~ NULL]) ifTrue: [myValue := (myRegion coordinateSpace cast: IDSpace) oldIDs: (myBackends fetch cast: Sequence) with: (myIDs fetch cast: IntegerRegion)]. ^myValue! {BooleanVar} hasValue ^myInexplicit ~~ NULL or: [myBackends ~~ NULL]! {void} step myInexplicit ~~ NULL ifTrue: [myInexplicit := NULL] ifFalse: [myBackends ~~ NULL ifTrue: [myValue := NULL. myIDs step. myIDs hasValue ifFalse: [myBackends step. myBackends hasValue ifFalse: [myBackends := NULL. myIDs := NULL. ^VOID]. myIDs := (myRegion iDNumbersFrom: (myBackends fetch cast: Sequence)) simpleRegions]]]! !Stepper subclass: #IDStepper instanceVariableNames: ' myRegion {IDRegion} myBackends {Stepper | NULL of: Sequence} myIDs {Stepper | NULL of: IntegerPos} myValue {ID | NULL}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-id'! (IDStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !IDStepper methodsFor: 'create'! {Stepper} copy ^IDStepper create: myRegion with: myBackends copy with: myIDs copy! create: region {IDRegion} super create. myRegion := region. myBackends := region backends stepper. myBackends hasValue ifTrue: [myIDs := (region iDNumbersFrom: (myBackends fetch cast: Sequence)) stepper] ifFalse: [myIDs := NULL. myBackends := NULL]. myValue := NULL.! create: region {IDRegion} with: backends {Stepper of: Sequence} with: iDs {Stepper of: IntegerPos} super create. myRegion := region. myBackends := backends. myIDs := iDs. myValue := NULL.! ! !IDStepper methodsFor: 'operations'! {Heaper wimpy} fetch (myValue == NULL and: [myBackends ~~ NULL]) ifTrue: [myValue := ID usingx: myRegion fetchSpace with: (myBackends fetch cast: Sequence) with: (myIDs fetch cast: IntegerPos) asIntegerVar]. ^myValue! {BooleanVar} hasValue ^myBackends ~~ NULL! {void} step myBackends ~~ NULL ifTrue: [myValue := NULL. myIDs step. myIDs hasValue ifFalse: [myBackends step. myBackends hasValue ifFalse: [myBackends := NULL. myIDs := NULL. ^VOID]. myIDs := (myRegion iDNumbersFrom: (myBackends fetch cast: Sequence)) stepper]]! !Stepper subclass: #IntegerEdgeStepper instanceVariableNames: ' myEntering {BooleanVar} myIndex {UInt32} myCount {UInt32} myEdges {IntegerVarArray}' classVariableNames: 'SomeEdgeSteppers {InstanceCache} ' poolDictionaries: '' category: 'Xanadu-Spaces-Integers'! IntegerEdgeStepper comment: 'A single instance of this class is cached. To take advantage of this, a method that uses IntegerEdgeSteppers should explicitly destroy at least one of them.'! (IntegerEdgeStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !IntegerEdgeStepper methodsFor: 'operations'! {Heaper wimpy} fetch self hasValue ifTrue: [^IntegerPos make: self edge] ifFalse: [^NULL]! {BooleanVar INLINE} hasValue ^myIndex < myCount! {void INLINE} step myEntering _ myEntering not. myIndex _ myIndex + 1! ! !IntegerEdgeStepper methodsFor: 'edge accessing'! {IntegerVar INLINE} edge "the current transition" (myIndex >= myCount) ifTrue: [ IntegerEdgeStepper outOfBounds ]. ^myEdges integerVarAt: myIndex! {BooleanVar INLINE} isEntering "whether the current transition is entering or leaving the set" ^myEntering! ! !IntegerEdgeStepper methodsFor: 'protected: create'! create: entering {BooleanVar} with: count {UInt32} with: edges {IntegerVarArray} super create. myEntering _ entering. myIndex _ Int32Zero. myCount _ count. myEdges _ edges! create: entering {BooleanVar} with: index {UInt32} with: count {UInt32} with: edges {IntegerVarArray} super create. myEntering _ entering. myIndex _ index. myCount _ count. myEdges _ edges! ! !IntegerEdgeStepper methodsFor: 'destroy'! {void} destroy (SomeEdgeSteppers store: self) ifFalse: [super destroy]! ! !IntegerEdgeStepper methodsFor: 'create'! {Stepper} copy ^IntegerEdgeStepper create: myEntering with: myIndex with: myCount with: myEdges! ! !IntegerEdgeStepper methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '('. self hasValue ifTrue: [self isEntering ifTrue: [oo << 'entering '] ifFalse: [oo << 'leaving ']. oo << self edge]. oo << ')'.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! IntegerEdgeStepper class instanceVariableNames: ''! (IntegerEdgeStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !IntegerEdgeStepper class methodsFor: 'errors'! {void} outOfBounds self BLAST: #OutOfBounds! ! !IntegerEdgeStepper class methodsFor: 'create'! make: entering {BooleanVar} with: count {UInt32} with: edges {IntegerVarArray} | result {Heaper} | result := SomeEdgeSteppers fetch. result == NULL ifTrue: [ ^ self create: entering with: count with: edges] ifFalse: [ ^ (self new.Become: result) create: entering with: count with: edges]! ! !IntegerEdgeStepper class methodsFor: 'smalltalk: init'! initTimeNonInherited SomeEdgeSteppers := InstanceCache make: 2! linkTimeNonInherited SomeEdgeSteppers := NULL! !Stepper subclass: #IntegerSimpleRegionStepper instanceVariableNames: ' myEdges {IntegerVarArray} myIndex {UInt32} myCount {UInt32} isLeftBounded {BooleanVar} mySimple {IntegerRegion}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Spaces-Integers'! (IntegerSimpleRegionStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !IntegerSimpleRegionStepper methodsFor: 'operations'! {Heaper wimpy} fetch ^mySimple! {BooleanVar} hasValue ^mySimple ~~ NULL! {void} step isLeftBounded ifTrue: [myIndex _ myIndex + 2] ifFalse: [myIndex _ myIndex + 1]. isLeftBounded _ true. myIndex < myCount ifTrue: [myIndex < (myCount - 1) ifTrue: [mySimple _ IntegerRegion make: (myEdges integerVarAt: myIndex) with: (myEdges integerVarAt: myIndex + 1)] ifFalse: [mySimple _ IntegerRegion after: (myEdges integerVarAt: myIndex)]] ifFalse: [mySimple _ NULL]! ! !IntegerSimpleRegionStepper methodsFor: 'unprotected create'! create: edges {IntegerVarArray} with: count {UInt32} with: leftBounded {BooleanVar} super create. myEdges _ edges. myIndex _ Int32Zero. myCount _ count. isLeftBounded _ leftBounded. count == Int32Zero ifTrue: [leftBounded ifTrue: [mySimple _ NULL] ifFalse: [mySimple _ IntegerRegion allIntegers]] ifFalse: [leftBounded not ifTrue: [mySimple _ IntegerRegion before: (edges integerVarAt: Int32Zero)] ifFalse: [count = 1 ifTrue: [mySimple _ IntegerRegion after: (edges integerVarAt: Int32Zero)] ifFalse: [mySimple _ IntegerRegion make: (edges integerVarAt: Int32Zero) with: (edges integerVarAt: 1)]]]! create: edges {IntegerVarArray} with: index {UInt32} with: count {UInt32} with: leftBounded {BooleanVar} with: simple {IntegerRegion} super create. myEdges _ edges. myIndex _ index. myCount _ count. isLeftBounded _ leftBounded. mySimple _ simple! ! !IntegerSimpleRegionStepper methodsFor: 'create'! {Stepper} copy ^IntegerSimpleRegionStepper create: myEdges with: myIndex with: myCount with: isLeftBounded with: mySimple! ! !IntegerSimpleRegionStepper methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '('. self hasValue ifTrue: [oo << self fetch]. oo << ')'! !Stepper subclass: #ItemStepper instanceVariableNames: 'myItem {Heaper | NULL}' classVariableNames: 'SomeSteppers {InstanceCache} ' poolDictionaries: '' category: 'Xanadu-stepper'! ItemStepper comment: 'This is a Stepper when you just want to step across a single item.'! (ItemStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !ItemStepper methodsFor: 'create'! {Stepper} copy myItem == NULL ifTrue: [ ^ self ] ifFalse: [ | result {Heaper} | result := SomeSteppers fetch. result == NULL ifTrue: [^ItemStepper create: myItem] ifFalse: [^(ItemStepper new.Become: result) create: myItem]]! create: item {Heaper | NULL} super create. myItem _ item! {void} destroy (SomeSteppers store: self) ifFalse: [super destroy]! ! !ItemStepper methodsFor: 'operations'! {Heaper wimpy} fetch ^myItem! {BooleanVar} hasValue ^myItem ~~ NULL! {void} step myItem _ NULL! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ItemStepper class instanceVariableNames: ''! (ItemStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !ItemStepper class methodsFor: 'smalltalk: init'! initTimeNonInherited SomeSteppers := InstanceCache make: 8! linkTimeNonInherited SomeSteppers := NULL! ! !ItemStepper class methodsFor: 'create'! {Stepper} make: item {Heaper} | result {Heaper} | result := SomeSteppers fetch. result == NULL ifTrue: [^ self create: item] ifFalse: [^ (self new.Become: result) create: item]! !Stepper subclass: #MergeBundlesStepper instanceVariableNames: ' myA {Stepper of: FeBundle} myB {Stepper of: FeBundle} myOrder {OrderSpec} myValue {FeBundle | NULL}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Ents'! MergeBundlesStepper comment: 'A Stepper for doing a merge-sort like ordered interleaving of two other steppers. It is assumed that the other two steppers are constructed so that their values are also produced in order according to the same OrderSpec. A tree of these operates much like a heap as found in heapsort.'! (MergeBundlesStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !MergeBundlesStepper methodsFor: 'operations'! {Stepper} copy myValue == NULL ifTrue: [^Stepper emptyStepper]. ^MergeBundlesStepper create: myA copy with: myB copy with: myOrder with: myValue! {Heaper wimpy} fetch ^myValue! {BooleanVar} hasValue ^myValue ~~ NULL! {void} step | a {FeBundle} b {FeBundle} | a := myA fetch cast: FeBundle. b := myB fetch cast: FeBundle. a == NULL ifTrue: [myValue := b. b ~~ NULL ifTrue: [myB step]. ^VOID]. b == NULL ifTrue: [myValue := a. myA step. ^VOID]. (myOrder preceeds: a region with: b region) ifTrue: [myValue := a. myA step] ifFalse: [myValue := b. myB step]! ! !MergeBundlesStepper methodsFor: 'private: creation'! create: a {Stepper of: Position} with: b {Stepper of: Position} with: order {OrderSpec} with: value {FeBundle | NULL} super create. myA := a. myB := b. myOrder := order. myValue := value. value == NULL ifTrue: [self step]! ! !MergeBundlesStepper methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myA _ receiver receiveHeaper. myB _ receiver receiveHeaper. myOrder _ receiver receiveHeaper. myValue _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myA. xmtr sendHeaper: myB. xmtr sendHeaper: myOrder. xmtr sendHeaper: myValue.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MergeBundlesStepper class instanceVariableNames: ''! (MergeBundlesStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !MergeBundlesStepper class methodsFor: 'creation'! {Stepper} make: a {Stepper of: FeBundle} with: b {Stepper of: FeBundle} with: order {OrderSpec} a hasValue ifFalse: [^b]. b hasValue ifFalse: [^a]. ^self create: a with: b with: order with: NULL! !Stepper subclass: #MergeStepper instanceVariableNames: ' myA {Stepper of: Position} myB {Stepper of: Position} myOrder {OrderSpec} myValue {Position | NULL}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Spaces-Cross'! MergeStepper comment: 'A Stepper for doing a merge-sort like ordered interleaving of two other steppers. It is assumed that the other two steppers are constructed so that their values are also produced in order according to the same OrderSpec. A tree of these operates much like a heap as found in heapsort.'! (MergeStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !MergeStepper methodsFor: 'operations'! {Stepper} copy myValue == NULL ifTrue: [^Stepper emptyStepper]. ^MergeStepper create: myA copy with: myB copy with: myOrder with: myValue! {Heaper wimpy} fetch ^myValue! {BooleanVar} hasValue ^myValue ~~ NULL! {void} step | a {Position} b {Position} | a := myA fetch cast: Position. b := myB fetch cast: Position. a == NULL ifTrue: [b == NULL ifTrue: [myValue := NULL] ifFalse: [myValue := b. myB step]] ifFalse: [b == NULL ifTrue: [myValue := a. myA step] ifFalse: [(myOrder follows: a with: b) ifTrue: [myValue := b. myB step. (a isEqual: b) ifTrue: [myA step]] ifFalse: [myValue := a. myA step. (a isEqual: b) ifTrue: [myB step]]]]! ! !MergeStepper methodsFor: 'private: creation'! create: a {Stepper of: Position} with: b {Stepper of: Position} with: order {OrderSpec} with: value {Position | NULL} super create. myA := a. myB := b. myOrder := order. myValue := value. value == NULL ifTrue: [self step]! ! !MergeStepper methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myA _ receiver receiveHeaper. myB _ receiver receiveHeaper. myOrder _ receiver receiveHeaper. myValue _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myA. xmtr sendHeaper: myB. xmtr sendHeaper: myOrder. xmtr sendHeaper: myValue.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MergeStepper class instanceVariableNames: ''! (MergeStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !MergeStepper class methodsFor: 'pseudoconstructors'! {Stepper} make: a {Stepper of: Position} with: b {Stepper of: Position} with: order {OrderSpec} ^self create: a with: b with: order with: NULL! !Stepper subclass: #PrimIndexTableStepper instanceVariableNames: ' myPtrs {PtrArray} myIndices {IntegerVarArray} myIndex {Int4}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-primtab'! PrimIndexTableStepper comment: 'Stepper over map from pointers to integers'! (PrimIndexTableStepper getOrMakeCxxClassDescription) friends: '/* friends for class PrimIndexTableStepper */ friend class PrimIndexTable;'; attributes: ((Set new) add: #CONCRETE; yourself)! !PrimIndexTableStepper methodsFor: 'accessing'! {Heaper wimpy} fetch myIndex < myPtrs count ifTrue: [ ^ IntegerPos make: (myIndices integerVarAt: myIndex) ] ifFalse: [ ^ NULL ]! {BooleanVar} hasValue ^ myIndex < myPtrs count! {Heaper} key "This does not necessarily return a Position" myIndex < myIndices count ifTrue: [^ myPtrs fetch: myIndex]. Heaper BLAST: #EmptyStepper. ^ NULL "Hush up the compiler"! {void} step |tmp {Heaper wimpy} | myIndex := myIndex + 1. [myIndex < myPtrs count and: [(tmp _ myPtrs fetch: myIndex) == NULL or: [tmp == PrimRemovedObject make]]] whileTrue: [ myIndex := myIndex + 1 ].! {IntegerVar} value myIndex < myPtrs count ifTrue: [ ^ myIndices integerVarAt: myIndex] ifFalse: [ Heaper BLAST: #EmptyStepper. ^ NULL ]! ! !PrimIndexTableStepper methodsFor: 'protected: create'! create: from {PtrArray} with: to {IntegerVarArray} with: index {Int32} | tmp {Heaper wimpy} | super create. myPtrs := from. myIndices := to. myIndex := index. [myIndex < myPtrs count and: [(tmp _ myPtrs fetch: myIndex) == NULL or: [tmp == PrimRemovedObject make]]] whileTrue: [ myIndex := myIndex + 1 ].! ! !PrimIndexTableStepper methodsFor: 'create'! {Stepper} copy ^ PrimIndexTableStepper create: myPtrs with: myIndices with: myIndex! !Stepper subclass: #PrimPtr2PtrTableStepper instanceVariableNames: ' myFromPtrs {PtrArray} myToPtrs {PtrArray} myIndex {Int4}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-primtab'! (PrimPtr2PtrTableStepper getOrMakeCxxClassDescription) friends: '/* friends for class PrimPtr2PtrTableStepper */ friend class PrimPtr2PtrTable;'; attributes: ((Set new) add: #CONCRETE; yourself)! !PrimPtr2PtrTableStepper methodsFor: 'create'! {Stepper} copy ^ PrimPtr2PtrTableStepper create: myFromPtrs with: myToPtrs with: myIndex! ! !PrimPtr2PtrTableStepper methodsFor: 'accessing'! {Heaper wimpy} fetch myIndex < myToPtrs count ifTrue: [ ^ myToPtrs fetch: myIndex ] ifFalse: [ ^ NULL ]! {BooleanVar} hasValue ^ myIndex < myToPtrs count! {Heaper} heaperKey myIndex < myFromPtrs count ifTrue: [^ myFromPtrs fetch: myIndex] ifFalse: [ ^ NULL ]! {void} step |tmp {Heaper wimpy} | myIndex := myIndex + 1. [myIndex < myToPtrs count and: [(tmp _ myToPtrs fetch: myIndex) == NULL or: [tmp == PrimRemovedObject make]]] whileTrue: [ myIndex := myIndex + 1 ].! ! !PrimPtr2PtrTableStepper methodsFor: 'protected: create'! create: from {PtrArray} with: to {PtrArray} with: index {Int32} | tmp {Heaper wimpy} | super create. myFromPtrs := from. myToPtrs := to. myIndex := index. [myIndex < myToPtrs count and: [(tmp _ myToPtrs fetch: myIndex) == NULL or: [tmp == PrimRemovedObject make]]] whileTrue: [ myIndex := myIndex + 1 ].! !Stepper subclass: #PrimPtrTableStepper instanceVariableNames: ' myPtrs {PtrArray} myIndices {IntegerVarArray} myIndex {Int4}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-primtab'! PrimPtrTableStepper comment: 'Stepper over map from integers to strong or wimpy pointers'! (PrimPtrTableStepper getOrMakeCxxClassDescription) friends: '/* friends for class PrimPtrTableStepper */ friend class PrimPtrTable;'; attributes: ((Set new) add: #CONCRETE; yourself)! !PrimPtrTableStepper methodsFor: 'protected: create'! create: from {IntegerVarArray} with: to {PtrArray} with: index {Int32} | tmp {Heaper wimpy} | super create. myIndices := from. myPtrs := to. myIndex := index. [myIndex < myPtrs count and: [(tmp _ myPtrs fetch: myIndex) == NULL or: [tmp == PrimRemovedObject make]]] whileTrue: [ myIndex := myIndex + 1 ].! ! !PrimPtrTableStepper methodsFor: 'accessing'! {Heaper wimpy} fetch myIndex < myPtrs count ifTrue: [ ^ myPtrs fetch: myIndex ] ifFalse: [ ^ NULL ]! {BooleanVar} hasValue ^ myIndex < myPtrs count! {IntegerVar} index myIndex < myIndices count ifTrue: [^ myIndices integerVarAt: myIndex]. Heaper BLAST: #EmptyStepper. ^ NULL "Hush up the compiler"! {void} step |tmp {Heaper wimpy} | myIndex := myIndex + 1. [myIndex < myPtrs count and: [(tmp _ myPtrs fetch: myIndex) == NULL or: [tmp == PrimRemovedObject make]]] whileTrue: [ myIndex := myIndex + 1 ].! ! !PrimPtrTableStepper methodsFor: 'create'! {Stepper} copy ^ PrimPtrTableStepper create: myIndices with: myPtrs with: myIndex! !Stepper subclass: #PrimSetStepper instanceVariableNames: ' myPtrs {PtrArray} myIndex {Int4}' classVariableNames: 'SomeSteppers {InstanceCache} ' poolDictionaries: '' category: 'Xanadu-primtab'! (PrimSetStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !PrimSetStepper methodsFor: 'create'! {Stepper} copy | result {Heaper} | result := SomeSteppers fetch. result == NULL ifTrue: [^ PrimSetStepper create: myPtrs with: Int32Zero] ifFalse: [^ (PrimSetStepper new.Become: result) create: myPtrs with: Int32Zero]! create: array {PtrArray} with: index {Int32} | tmp {Heaper wimpy} | super create. myPtrs := array. myIndex := index. [myIndex < myPtrs count and: [(tmp _ myPtrs fetch: myIndex) == NULL or: [tmp == PrimRemovedObject make]]] whileTrue: [ myIndex := myIndex + 1 ].! {void} destroy (SomeSteppers store: self) ifFalse: [super destroy]! ! !PrimSetStepper methodsFor: 'accessing'! {Heaper wimpy} fetch myIndex < myPtrs count ifTrue: [ ^ myPtrs fetch: myIndex ] ifFalse: [ ^ NULL ]! {BooleanVar} hasValue ^ myIndex < myPtrs count! {void} step |tmp {Heaper wimpy} | myIndex := myIndex + 1. [myIndex < myPtrs count and: [(tmp _ myPtrs fetch: myIndex) == NULL or: [tmp == PrimRemovedObject make]]] whileTrue: [ myIndex := myIndex + 1 ].! ! !PrimSetStepper methodsFor: 'printint'! {void} printOn: oo {ostream reference} | printedElem {BooleanVar} | oo << 'PrimSetStepper on {'. printedElem := false. Int32Zero almostTo: myPtrs count do: [:i {Int32} | (myPtrs fetch: i) ~~ NULL ifTrue: [ printedElem ifTrue: [oo << ', ']. oo << (myPtrs fetch: i). printedElem := true]]. oo << '}'! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PrimSetStepper class instanceVariableNames: ''! (PrimSetStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !PrimSetStepper class methodsFor: 'create'! {Stepper} make: ptrs {PtrArray} | result {Heaper} | result := SomeSteppers fetch. result == NULL ifTrue: [^ PrimSetStepper create: ptrs with: Int32Zero] ifFalse: [^ (PrimSetStepper new.Become: result) create: ptrs with: Int32Zero]! ! !PrimSetStepper class methodsFor: 'smalltalk: init'! initTimeNonInherited SomeSteppers := InstanceCache make: 8! linkTimeNonInherited SomeSteppers := NULL! !Stepper subclass: #RealStepper instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-id'! (RealStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !RealStepper methodsFor: 'operations'! {Heaper wimpy} fetch "If I am exhausted (i.e., if (!! this->hasValue())), then return NULL. Else return current element. I return wimpily since most items returned are held by collections. If I create a new object, I should cache it." MarkM shouldImplement. ^NULL "fodder"! {BooleanVar} hasValue "Iff I have a current value (i.e. this message returns true), then I am not exhasted. 'fetch' and 'get' will both return this value, and I can be 'step'ped to my next state. As I am stepped, eventually I may become exhausted (the reverse of all the above), which is a permanent condition. Note that not all steppers have to be exhaustable. A Stepper which enumerates all primes is perfectly reasonable. Assuming otherwise will create infinite loops. See class comment." MarkM shouldImplement. ^false "fodder"! {void} step "Essential. If I am currently exhausted (see Stepper::hasValue()), then it is an error to step me. The result of doing so isn't currently specified (we probably should specify it to BLAST, but I know that the implementation doesn't currently live up to that spec). If I am not exhausted, then this advances me to my next state. If my current value (see Stepper::get()) was my final value, then I am now exhausted, otherwise my new current value is the next value." MarkM shouldImplement! ! !RealStepper methodsFor: 'create'! {Stepper} copy "Return a new stepper which steps independently of me, but whose current value is the same as mine, and which must produce a future history of values which satisfies the same obligation that my contract obligates me to produce now. Typically, this will mean that he must produce the same future history that I'm going to produce. However, let's say that I am enumerating the elements of a partial order in some full order which is consistent with the partial order. If a copy of me is made after I'm part way through, then me and my copy may produce any future history compatable both with the partial order and the elements I've already produced by the time of the copy. Of course, a subclass or a Stepper creating message (like IntegerRegion::stepper()) may specify the more stringent requirement (that a copy must produce the same sequence). To prevent aliasing, Steppers should typically be passed by copy. See class comment." MarkM shouldImplement. ^NULL "fodder"! create: transitions {PtrArray}! !Stepper subclass: #SequenceStepper instanceVariableNames: ' myIndex {Int32} myTransitions {PtrArray of: SequenceEdge} myTransitionsCount {Int32}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-id'! (SequenceStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !SequenceStepper methodsFor: 'operations'! {Heaper wimpy} fetch myIndex < myTransitionsCount ifTrue: [^((myTransitions fetch: myIndex) cast: SequenceEdge) sequence] ifFalse: [^NULL]! {BooleanVar} hasValue ^myIndex < myTransitionsCount! {void} step myIndex := myIndex + 2! ! !SequenceStepper methodsFor: 'create'! {Stepper} copy ^SequenceStepper create: myIndex with: myTransitions with: myTransitionsCount! create: transitions {PtrArray of: IDEdge} with: count {Int32} super create. myIndex := Int32Zero. myTransitions := transitions. myTransitionsCount := count.! create: index {Int32} with: transitions {PtrArray of: IDEdge} with: count {Int32} super create. myIndex := index. myTransitions := transitions. myTransitionsCount := count.! !Stepper subclass: #SetTableStepper instanceVariableNames: ' myPtrs {PtrArray} myIndex {Int32}' classVariableNames: ' AnArray {PtrArray} AStepper {SetTableStepper} ' poolDictionaries: '' category: 'Xanadu-settab'! (SetTableStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; yourself)! !SetTableStepper methodsFor: 'accessing'! {Heaper} fetch myIndex < myPtrs count ifTrue: [^ myPtrs fetch: myIndex] ifFalse: [^ NULL]! {BooleanVar} hasValue ^ myIndex < myPtrs count! {void} step myIndex := myIndex + 1! ! !SetTableStepper methodsFor: 'create'! {Stepper} copy ^ SetTableStepper create: (myPtrs copy cast: PtrArray) with: myIndex! {void} destroy AStepper == NULL ifTrue: [ myPtrs storeAll. AnArray := myPtrs cast: PtrArray. AStepper := self. self destruct] ifFalse: [ super destroy].! ! !SetTableStepper methodsFor: 'protected: create'! create: array {PtrArray} super create. myPtrs := array. myIndex := Int32Zero.! create: array {PtrArray} with: index {Int32} super create. myPtrs := array. myIndex := index.! ! !SetTableStepper methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! SetTableStepper class instanceVariableNames: ''! (SetTableStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; yourself)! !SetTableStepper class methodsFor: 'smalltalk: init'! linkTimeNonInherited AnArray := NULL. AStepper := NULL.! ! !SetTableStepper class methodsFor: 'create'! make: array {PtrArray} AStepper ~~ NULL ifTrue: [ | result {SetTableStepper} | result := ((SetTableStepper new.Become: AStepper) create: array) . AStepper := NULL. ^ result] ifFalse: [ ^ SetTableStepper create: array]! ! !SetTableStepper class methodsFor: 'accessing'! {PtrArray} array AnArray ~~ NULL ifTrue: [ | result {PtrArray} | result := AnArray. AnArray := NULL. ^ result] ifFalse: [ ^ PtrArray nulls: 16]! !Stepper subclass: #TableStepper instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Steppers'! TableStepper comment: 'For enumerating the key->value associations of a table. A typical use (for a table whose range elements were all Foos) might be: SPTR(TableStepper) stomp = table->stepper(); FOR_EACH(Foo,f,stomp, { doSomethingWith(stomp->key(), z); }); Each iteration of the loop would correspond to an association of the table (snapshotted at the time "->stepper()" was sent). For each association, "f" (a pointer to Foo) points at the range element, while "stomp->key()" provides the domain element. See ScruTable::stepper.'! (TableStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; yourself)! !TableStepper methodsFor: 'smalltalk: operations'! {void} forIndices: fn {BlockClosure of: IntegerVar with: Heaper} [| result {Heaper} | [(result _ self fetch) ~~ NULL] whileTrue: [fn of: self index and: result. self step]] valueNowOrOnUnwindDo: [self destroy]! {void} forKeyValues: fn {BlockClosure of: Position with: Heaper} [| result {Heaper} | [(result _ self fetch) ~~ NULL] whileTrue: [fn of: self position and: result. self step]] valueNowOrOnUnwindDo: [self destroy]! {void} forPositions: fn {BlockClosure of: Position with: Heaper} [| result {Heaper} | [(result _ self fetch) ~~ NULL] whileTrue: [fn of: self position and: result. self step]] valueNowOrOnUnwindDo: [self destroy]! {Position} key "A TableStepper actually enumerates the associations of a table. Through the normal Stepper protocol, it makes available the range element of the current association. Through this additional protocol, it make accessible the key of the current association. This message returns the same object as TwoStepper::other, the only difference being the static knowledge that it's a Position." ^ self position! ! !TableStepper methodsFor: 'special'! {IntegerVar} index "Unboxed version of TableStepper::key. See class comment in XuInteger." ^(self position cast: IntegerPos) asIntegerVar! {Position CLIENT} position "A TableStepper actually enumerates the associations of a table. Through the normal Stepper protocol, it makes available the range element of the current association. Through this additional protocol, it make accessible the key of the current association. This message returns the same object as TwoStepper::other, the only difference being the static knowledge that it's a Position." self subclassResponsibility! ! !TableStepper methodsFor: 'create'! {Stepper} copy self subclassResponsibility! ! !TableStepper methodsFor: 'operations'! {Heaper wimpy} fetch self subclassResponsibility! {BooleanVar} hasValue self subclassResponsibility! {void} step self subclassResponsibility! {PrimArray CLIENT} stepManyPairs: count {Int32 default: -1} "An array of the remaining elements in alternating positions in the array [k1, v1, k2, v2, k3, v3, ...] Returns an array of up to count * 2 elements (or some arbitrary number if count is negative), and steps the stepper the corresponding number of times. You should check whether the stepper is atEnd, since it can stop before the number you give it because of some internal limit or grouping issue." | result {Accumulator} n {Int32} | count >= Int32Zero ifTrue: [n := count * 2] ifFalse: [n := 1000]. result := PtrArrayAccumulator create: n. n := Int32Zero. [self hasValue and: [(count < Int32Zero and: [n < 1000]) or: [n < count]]] whileTrue: [result step: self position. result step: self fetch. self step. n := n + 1]. ^result value cast: PrimArray! ! !TableStepper methodsFor: 'smalltalk: delayed iteration'! {void} forPromisedPairs: aBlock self knownBug. "only works outside of a delay block" [self atEnd value] whileFalse: [aBlock value: (XuPromise dynamicType: self position) value: (XuPromise dynamicType: self get). self step]! ! !TableStepper methodsFor: 'smalltalk: defaults'! {PrimArray CLIENT} stepManyPairs ^self stepManyPairs: -1! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TableStepper class instanceVariableNames: ''! (TableStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; yourself)! !TableStepper class methodsFor: 'smalltalk: system'! info.stProtocol "{Position CLIENT} position {PrimArray CLIENT} stepManyPairs: count {Int32 default: -1} "! ! !TableStepper class methodsFor: 'creation'! {TableStepper INLINE} ascending: array {PtrArray} "Note: this being a low level operation, and there being no lightweight form of immutable or lazily copied PtrArray, it is my caller's responsibility to pass me a PtrArray which will in fact not be changed during the life of this stepper. This is an unchecked an uncheckable precondition on my clients." ^PtrArrayStepper ascending: array! {TableStepper INLINE} descending: array {PtrArray} "Note: this being a low level operation, and there being no lightweight form of immutable or lazily copied PtrArray, it is my caller's responsibility to pass me a PtrArray which will in fact not be changed during the life of this stepper. This is an unchecked an uncheckable precondition on my clients." ^PtrArrayStepper descending: array! !TableStepper subclass: #ArrayStepper instanceVariableNames: ' arrayInternal {ActualArray} indexInternal {Int32}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Steppers'! (ArrayStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #NOT.A.TYPE; add: #DEFERRED; yourself)! !ArrayStepper methodsFor: 'operations'! {Heaper wimpy} fetch self subclassResponsibility! {Heaper wimpy} get ^arrayInternal intGet: indexInternal! {BooleanVar} hasValue self subclassResponsibility! {void} step self subclassResponsibility! ! !ArrayStepper methodsFor: 'special'! {IntegerVar} index ^indexInternal! {Position} position ^indexInternal integer! ! !ArrayStepper methodsFor: 'protected: accessing'! {ActualArray} array ^arrayInternal! {void} setIndex: i {Int32} indexInternal _ i! ! !ArrayStepper methodsFor: 'create'! {Stepper} copy self subclassResponsibility! ! !ArrayStepper methodsFor: 'protected: create'! create: array {MuArray} super create. arrayInternal _ array copy cast: ActualArray. indexInternal _ Int32Zero! create: array {MuArray} with: index {IntegerVar} super create. arrayInternal _ array copy cast: ActualArray. indexInternal _ index DOTasLong! !ArrayStepper subclass: #AscendingArrayStepper instanceVariableNames: 'lastValueInternal {Int32}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Steppers'! (AscendingArrayStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !AscendingArrayStepper methodsFor: 'create'! {Stepper} copy ^AscendingArrayStepper make: self array with: self index with: lastValueInternal! ! !AscendingArrayStepper methodsFor: 'protected: create'! create: array {ActualArray} super create: array. lastValueInternal _ array endOffset! create: array {ActualArray} with: index {IntegerVar} super create: array with: index. lastValueInternal _ array endOffset! create: array {ActualArray} with: start {IntegerVar} with: stop {IntegerVar} super create: array with: start. lastValueInternal _ stop DOTasLong! ! !AscendingArrayStepper methodsFor: 'operations'! {Heaper wimpy} fetch self hasValue ifTrue: [^self array elementsArray fetch: self index DOTasLong] ifFalse: [^NULL]! {BooleanVar} hasValue ^self index <= lastValueInternal! {void} step self setIndex: self index DOTasLong + 1! ! !AscendingArrayStepper methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << ' on ' << (self array subTableBetween: self index with: lastValueInternal)! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AscendingArrayStepper class instanceVariableNames: ''! (AscendingArrayStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !AscendingArrayStepper class methodsFor: 'create'! {TableStepper} make: array {ActualArray} ^ self create: array! {TableStepper} make: array {ActualArray} with: index {IntegerVar} ^ self create: array with: index! {TableStepper} make: array {ActualArray} with: start {IntegerVar} with: stop {IntegerVar} ^ self create: array with: start with: stop! !TableStepper subclass: #BucketArrayStepper instanceVariableNames: ' myEntry {TableEntry | NULL} myEntries {SharedPtrArray of: TableEntry} myNextBucket {Int4}' classVariableNames: 'SomeSteppers {InstanceCache} ' poolDictionaries: '' category: 'Xanadu-Collection-SetTable'! (BucketArrayStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !BucketArrayStepper methodsFor: 'operations'! {Heaper wimpy} fetch myEntry == NULL ifTrue: [^NULL] ifFalse: [^myEntry value]! {BooleanVar} hasValue ^myEntry ~~ NULL! {void} step myEntry ~~ NULL ifTrue: [ myEntry _ myEntry fetchNext. self verifyEntry]! ! !BucketArrayStepper methodsFor: 'private:'! {void} verifyEntry "Step through the bucket till we find something with a matching key." | bucket {Int32} | "use a local index to avoid pointer refs in loop" myEntry ~~ NULL ifTrue: [^VOID]. bucket _ myNextBucket. [bucket < myEntries count] whileTrue: [|nextEntry {Heaper wimpy}| nextEntry _ myEntries fetch: bucket. bucket _ bucket + 1. nextEntry ~~ NULL ifTrue: [myEntry _ nextEntry cast: TableEntry. myNextBucket _ bucket. ^VOID]]. myEntries := NULL.! ! !BucketArrayStepper methodsFor: 'special'! {IntegerVar} index myEntry ~~ NULL assert: 'Illegal access'. ^myEntry index! {Position} position myEntry ~~ NULL assert: 'Illegal access'. ^myEntry position! ! !BucketArrayStepper methodsFor: 'protected: create'! create: entries {SharedPtrArray} with: entry {TableEntry | NULL} with: nextBucket {Int32} super create. myEntry _ entry. myEntries _ entries. myNextBucket _ nextBucket. myEntries shareMore. self verifyEntry! {void} destruct myEntries ~~ NULL ifTrue: [ myEntries shareLess]. super destruct! ! !BucketArrayStepper methodsFor: 'create'! {Stepper} copy | result {Heaper} | result := SomeSteppers fetch. result == NULL ifTrue: [^BucketArrayStepper create: myEntries with: myEntry with: myNextBucket] ifFalse: [^(BucketArrayStepper new.Become: result) create: myEntries with: myEntry with: myNextBucket]! {void} destroy (SomeSteppers store: self) ifFalse: [super destroy]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BucketArrayStepper class instanceVariableNames: ''! (BucketArrayStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !BucketArrayStepper class methodsFor: 'smalltalk: init'! initTimeNonInherited SomeSteppers := InstanceCache make: 8! linkTimeNonInherited SomeSteppers := NULL! ! !BucketArrayStepper class methodsFor: 'creation'! {TableStepper} make: entries {SharedPtrArray} | result {Heaper} | result := SomeSteppers fetch. result == NULL ifTrue: [^self create: entries with: NULL with: Int32Zero] ifFalse: [^(self new.Become: result) create: entries with: NULL with: Int32Zero]! !TableStepper subclass: #EditionStepper instanceVariableNames: ' myKeys {Stepper of: Position} myEdition {FeEdition}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-nbacken'! (EditionStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !EditionStepper methodsFor: 'create'! {Stepper} copy ^EditionStepper create: myKeys copy with: myEdition! create: keys {Stepper of: Position} with: edition {FeEdition} super create. myKeys := keys. myEdition := edition.! ! !EditionStepper methodsFor: 'special'! {Position} position ^myKeys get cast: Position! ! !EditionStepper methodsFor: 'operations'! {Heaper wimpy} fetch myKeys hasValue ifTrue: [^myEdition get: (myKeys fetch cast: Position)] ifFalse: [^NULL]! {BooleanVar} hasValue ^myKeys hasValue! {void} step myKeys step! !TableStepper subclass: #GrandHashTableStepper instanceVariableNames: ' table {GrandHashTable} nodeStepper {GrandNodeStepper | NULL} nodeIndex {IntegerVar}' classVariableNames: '' poolDictionaries: '' category: 'Cxx-class-stuff'! (GrandHashTableStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !GrandHashTableStepper methodsFor: 'private: private'! {void} verifyEntry [nodeIndex < table nodeCount and: [(table nodeAt: nodeIndex) isEmpty]] whileTrue: [nodeIndex _ nodeIndex + 1 ]. nodeIndex < table nodeCount ifTrue: [nodeStepper _ GrandNodeStepper create: (table nodeAt: nodeIndex)]! ! !GrandHashTableStepper methodsFor: 'operations'! {Heaper wimpy} fetch (nodeStepper ~~ NULL and: [nodeStepper hasValue]) ifTrue: [^ nodeStepper entry value] ifFalse: [^NULL]! {BooleanVar} hasValue ^ nodeStepper ~~ NULL! {void} step nodeStepper step. nodeStepper hasValue ifFalse: [nodeStepper destroy. nodeStepper _ NULL. nodeIndex _ nodeIndex + 1. self verifyEntry]! ! !GrandHashTableStepper methodsFor: 'special'! {Position} position ^ (nodeStepper entry cast: GrandTableEntry) position! ! !GrandHashTableStepper methodsFor: 'create'! {Stepper} copy ^ GrandHashTableStepper create: table with: nodeStepper with: nodeIndex! create: aTable {GrandHashTable} super create. table _ aTable. table moreSteppers. nodeIndex _ IntegerVar0. nodeStepper _ NULL. self verifyEntry! ! !GrandHashTableStepper methodsFor: 'protected: creation'! create: aTable {GrandHashTable} with: aNodeStepper {GrandNodeStepper} with: aNodeIndex {IntegerVar} super create. table _ aTable. table moreSteppers. nodeStepper _ aNodeStepper. nodeIndex _ aNodeIndex.! {void} destruct nodeStepper ~~ NULL ifTrue: [ nodeStepper destroy ]. table fewerSteppers. super destruct.! !TableStepper subclass: #GrantStepper instanceVariableNames: ' myBundles {Stepper of: FeBundle} myClubIDs {IDRegion | NULL}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-nbacken'! GrantStepper comment: 'Has a Bundle Stepper on a piece of the Edition defining the grants for this Server, and views it as a sequence of associations from ClubIDs to IDRegions (which is the inverse of its actual format)'! (GrantStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !GrantStepper methodsFor: 'special'! {Position} position Ravi thingToDo. "in future implementations this might also get back an ArrayBundle" ^CurrentGrandMap fluidGet iDOf: (myBundles get cast: FeElementBundle) element getOrMakeBe! ! !GrantStepper methodsFor: 'operations'! {Heaper wimpy} fetch | bundle {FeBundle} | bundle := myBundles fetch cast: FeBundle. bundle == NULL ifTrue: [^NULL]. ^bundle region! {BooleanVar} hasValue ^myBundles hasValue! {void} step [myBundles hasValue] whileTrue: [myBundles step. (myClubIDs == NULL or: [myClubIDs hasMember: self position]) ifTrue: [^VOID]]! ! !GrantStepper methodsFor: 'create'! {Stepper} copy ^GrantStepper create: myBundles copy with: myClubIDs! create: bundles {Stepper of: FeBundle} with: clubIDs {IDRegion | NULL} super create. myBundles := bundles. myClubIDs := clubIDs.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GrantStepper class instanceVariableNames: ''! (GrantStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !GrantStepper class methodsFor: 'create'! {TableStepper} make: grants {BeEdition} with: clubIDs {IDRegion | NULL} ^self create: grants retrieve with: clubIDs! !TableStepper subclass: #IntegerTableStepper instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Steppers'! IntegerTableStepper comment: 'Consider this a protected class. It is public only for use by the "array" module.'! (IntegerTableStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !IntegerTableStepper methodsFor: 'operations'! {Heaper wimpy} fetch self subclassResponsibility! {Heaper wimpy} get | res {Heaper wimpy} | res _ self fetch. res == NULL ifTrue: [Heaper BLAST: #EmptyStepper]. ^res! {BooleanVar} hasValue self subclassResponsibility! {void} step self subclassResponsibility! ! !IntegerTableStepper methodsFor: 'special'! {Position} position self subclassResponsibility! ! !IntegerTableStepper methodsFor: 'create'! {Stepper} copy self subclassResponsibility! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! IntegerTableStepper class instanceVariableNames: ''! (IntegerTableStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !IntegerTableStepper class methodsFor: 'pseudoConstructors'! make: aTable {IntegerTable} with: anOrder {OrderSpec default: NULL} "Do not consider public. Only for use by the modules inttab, array, and awarray." aTable cast: ActualIntegerTable into: [:tab | (anOrder followsInt: 1 with: IntegerVar0) ifTrue: [^ITAscendingStepper create: tab] ifFalse: [^ITDescendingStepper create: tab]] others: [anOrder == NULL ifTrue: [^ITGenericStepper create: aTable] ifFalse: [^ITGenericStepper create: aTable with.OrderSpec: anOrder]]. ^ NULL "compiler fodder"! make: aTable {IntegerTable} with: start {IntegerVar} with: stop {IntegerVar} "Do not consider public. Only for use by the modules inttab, array, and awarray." aTable cast: ActualIntegerTable into: [:tab | ^ITAscendingStepper create: tab with: start with: stop] others: [^ITGenericStepper create: aTable with: start with: stop with: 1]. ^ NULL "compiler fodder"! ! !IntegerTableStepper class methodsFor: 'smalltalk: smalltalk creation'! create: onTable {IntegerTable} with.OrderSpec: anOrderSpec {OrderSpec} ^ self new create: onTable with.OrderSpec: anOrderSpec! !IntegerTableStepper subclass: #ITAscendingStepper instanceVariableNames: ' arrayInternal {OberIntegerTable} indexInternal {UInt32} lastValueInternal {UInt32}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Steppers'! (ITAscendingStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !ITAscendingStepper methodsFor: 'operations'! {Heaper wimpy} fetch (indexInternal <= lastValueInternal) ifTrue: [^arrayInternal elementsArray fetch: indexInternal] ifFalse: [^NULL]! {BooleanVar} hasValue ^ indexInternal <= lastValueInternal! {void} step indexInternal _ indexInternal + 1. [indexInternal <= lastValueInternal and: [(arrayInternal elementsArray fetch: indexInternal) == NULL]] whileTrue: [indexInternal _ indexInternal + 1]! ! !ITAscendingStepper methodsFor: 'create'! {Stepper} copy ^ITAscendingStepper create: (arrayInternal copy cast: OberIntegerTable) with: self index with: arrayInternal startIndex + lastValueInternal! create: array {OberIntegerTable} super create. arrayInternal _ (array copy cast: OberIntegerTable). indexInternal _ arrayInternal startOffset. lastValueInternal _ arrayInternal endOffset. self verifyEntry! create: array {OberIntegerTable} with: index {IntegerVar} super create. arrayInternal _ (array copy cast: OberIntegerTable). indexInternal _ (index - arrayInternal startIndex) DOTasLong. lastValueInternal _ arrayInternal endOffset. self verifyEntry! create: array {OberIntegerTable} with: start {IntegerVar} with: stop {IntegerVar} "n.b. !!!!!!!! This constructor DOES NOT COPY the table because this constructor is used by the table copy (which creates a stepper). The copy is done in the table->stepper(NULL) routine before calling this constructor." super create. arrayInternal _ array. indexInternal _ (start - arrayInternal startIndex) DOTasLong. lastValueInternal _ (stop - arrayInternal startIndex) DOTasLong. self verifyEntry! ! !ITAscendingStepper methodsFor: 'special'! {IntegerVar} index ^arrayInternal startIndex + indexInternal! {Position} position ^ self index integer! ! !ITAscendingStepper methodsFor: 'private: private'! {void} verifyEntry [indexInternal <= lastValueInternal and: [(arrayInternal elementsArray fetch: indexInternal) == NULL]] whileTrue: [indexInternal _ indexInternal + 1]! !IntegerTableStepper subclass: #ITDescendingStepper instanceVariableNames: ' arrayInternal {OberIntegerTable} indexInternal {UInt32} lastValueInternal {UInt32}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Steppers'! (ITDescendingStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !ITDescendingStepper methodsFor: 'create'! {Stepper} copy ^ITDescendingStepper create: (arrayInternal copy cast: ActualIntegerTable) with: self index with: arrayInternal startIndex + lastValueInternal! create: array {OberIntegerTable} super create. arrayInternal _ array copy cast: OberIntegerTable. indexInternal _ arrayInternal endOffset. lastValueInternal _ arrayInternal startOffset. self verifyEntry! create: array {OberIntegerTable} with: index {IntegerVar} super create. arrayInternal _ array copy cast: OberIntegerTable. indexInternal _ (index - arrayInternal startIndex) DOTasLong. lastValueInternal _ arrayInternal startOffset. self verifyEntry! create: array {OberIntegerTable} with: start {IntegerVar} with: stop {IntegerVar} super create. arrayInternal _ array copy cast: OberIntegerTable. indexInternal _ (start - arrayInternal startIndex) DOTasLong. lastValueInternal _ (stop - arrayInternal startIndex) DOTasLong. self verifyEntry! ! !ITDescendingStepper methodsFor: 'operations'! {Heaper wimpy} fetch indexInternal >= lastValueInternal ifTrue: [^arrayInternal elementsArray fetch: indexInternal] ifFalse: [^NULL]! {BooleanVar} hasValue ^indexInternal >= lastValueInternal! {void} step indexInternal _ indexInternal - 1. self verifyEntry! ! !ITDescendingStepper methodsFor: 'special'! {IntegerVar} index ^ arrayInternal startIndex + indexInternal! {Position} position ^ self index integer! ! !ITDescendingStepper methodsFor: 'private: private'! {void} verifyEntry [indexInternal >= lastValueInternal and: [(arrayInternal elementsArray fetch: indexInternal) == NULL]] whileTrue: [indexInternal _ indexInternal - 1]! !IntegerTableStepper subclass: #ITGenericStepper instanceVariableNames: ' arrayInternal {IntegerTable} indexInternal {IntegerVar} lastValueInternal {IntegerVar} incrementInternal {Int32}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Steppers'! (ITGenericStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !ITGenericStepper methodsFor: 'operations'! {Heaper wimpy} fetch self hasValue ifTrue: [^ arrayInternal intFetch: indexInternal] ifFalse: [^NULL]! {BooleanVar} hasValue ^(incrementInternal > Int32Zero and: [indexInternal <= lastValueInternal]) or: [incrementInternal < Int32Zero and: [indexInternal >= lastValueInternal]]! {void} step indexInternal _ indexInternal + incrementInternal. self verifyEntry! ! !ITGenericStepper methodsFor: 'special'! {IntegerVar} index ^indexInternal! {Position} position ^indexInternal integer! ! !ITGenericStepper methodsFor: 'create'! {Stepper} copy ^ITGenericStepper create: arrayInternal with: indexInternal with: lastValueInternal with: incrementInternal! create: array {IntegerTable} super create. arrayInternal _ (array copy cast: IntegerTable). indexInternal _ IntegerVar0. lastValueInternal _ arrayInternal highestIndex. incrementInternal _ 1! create: onTable {IntegerTable} with.OrderSpec: anOrder {OrderSpec} super create. (anOrder followsInt: 1 with: IntegerVar0) ifTrue: "order is ascending" [arrayInternal _ (onTable copy cast: IntegerTable). indexInternal _ onTable lowestIndex. lastValueInternal _ onTable highestIndex. incrementInternal _ 1] ifFalse: "order is descending" [arrayInternal _ (onTable copy cast: IntegerTable). indexInternal _ onTable highestIndex. lastValueInternal _ onTable lowestIndex. incrementInternal _ -1]! create: array {IntegerTable} with: index {IntegerVar} super create. arrayInternal _ array copy cast: IntegerTable. indexInternal _ index. lastValueInternal _ arrayInternal highestIndex. incrementInternal _ 1! create: array {IntegerTable} with: start {IntegerVar} with: stop {IntegerVar} super create. arrayInternal _ array copy cast: IntegerTable. indexInternal _ start. lastValueInternal _ stop. incrementInternal _ 1! create: array {IntegerTable} with: start {IntegerVar} with: stop {IntegerVar} with: direction {IntegerVar} super create. arrayInternal _ array copy cast: IntegerTable. indexInternal _ start. lastValueInternal _ stop. incrementInternal _ direction DOTasLong! ! !ITGenericStepper methodsFor: 'private: private'! {void} verifyEntry | notDone {BooleanVar} | notDone _ true. [notDone] whileTrue: [ ((incrementInternal > Int32Zero and: [indexInternal < lastValueInternal]) or: [incrementInternal < Int32Zero and: [indexInternal >= lastValueInternal]]) ifTrue: [(arrayInternal intFetch: indexInternal) == NULL ifTrue: [indexInternal _ indexInternal + incrementInternal] ifFalse: [notDone _ false]] ifFalse: [notDone _ false]]! !TableStepper subclass: #OffsetArrayStepper instanceVariableNames: ' myArrayStepper {TableStepper} myDsp {Dsp}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Steppers'! (OffsetArrayStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !OffsetArrayStepper methodsFor: 'operations'! {Heaper wimpy} fetch ^ myArrayStepper fetch! {Heaper wimpy} get ^ myArrayStepper get! {BooleanVar} hasValue ^myArrayStepper hasValue! {void} step myArrayStepper step! ! !OffsetArrayStepper methodsFor: 'special'! {IntegerVar} index ^myDsp ofInt: myArrayStepper index! {Position} position ^myDsp of: myArrayStepper position! ! !OffsetArrayStepper methodsFor: 'protected: create'! create.Stepper: onStepper {TableStepper} with: aDsp {Dsp} super create. myArrayStepper _ onStepper. myDsp _ aDsp! ! !OffsetArrayStepper methodsFor: 'create'! {Stepper} copy ^ OffsetArrayStepper make: (myArrayStepper copy cast: TableStepper) with: myDsp! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! OffsetArrayStepper class instanceVariableNames: ''! (OffsetArrayStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !OffsetArrayStepper class methodsFor: 'smalltalk: creation'! create.Stepper: aStepper ^ self new create.Stepper: aStepper! create.Stepper: aStepper with: aDsp ^ self new create.Stepper: aStepper with: aDsp! ! !OffsetArrayStepper class methodsFor: 'create'! {TableStepper} make: arrayStepper {TableStepper} with: aDsp {Dsp} ^self create.Stepper: arrayStepper with: aDsp! !TableStepper subclass: #OffsetScruTableStepper instanceVariableNames: ' myTableStepper {TableStepper} myDsp {Dsp}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Steppers'! (OffsetScruTableStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !OffsetScruTableStepper methodsFor: 'operations'! {Heaper wimpy} fetch ^ myTableStepper fetch! {Heaper wimpy} get ^ myTableStepper get! {BooleanVar} hasValue ^myTableStepper hasValue! {void} step myTableStepper step! ! !OffsetScruTableStepper methodsFor: 'special'! {IntegerVar} index ^myDsp ofInt: myTableStepper index! {Position} position ^myDsp of: myTableStepper position! ! !OffsetScruTableStepper methodsFor: 'create'! {Stepper} copy ^ OffsetScruTableStepper create.Stepper: (myTableStepper copy cast: TableStepper) with: myDsp! create.Stepper: onStepper {TableStepper} with: aDsp {Dsp} super create. myTableStepper _ onStepper. myDsp _ aDsp! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! OffsetScruTableStepper class instanceVariableNames: ''! (OffsetScruTableStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !OffsetScruTableStepper class methodsFor: 'smalltalk: smalltalk creation'! create.Stepper: aStepper with: aDsp ^ self new create.Stepper: aStepper with: aDsp! !TableStepper subclass: #PtrArrayStepper instanceVariableNames: ' myArray {PtrArray of: Heaper} myIndex {Int32} myPastEnd {Int32} myStep {Int32}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Spaces-Cross'! PtrArrayStepper comment: 'A Stepper for stepping over the elements of a PtrArray in ascending or descending order. This is a TableStepper even though it is stepping over a PtrArray instead of a table. Should probably eventually be generalized to PrimArrays. NOT.A.TYPE'! (PtrArrayStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !PtrArrayStepper methodsFor: 'operations'! {Stepper} copy ^PtrArrayStepper create: (myArray copy cast: PtrArray) with: myIndex with: myPastEnd with: myStep! {Heaper wimpy} fetch myIndex >= myPastEnd ifTrue: [^NULL]. ^myArray fetch: myIndex! {BooleanVar} hasValue ^myIndex < myPastEnd! {void} step myIndex _ myIndex + myStep! ! !PtrArrayStepper methodsFor: 'special'! {IntegerVar} index myIndex >= myPastEnd ifTrue: [Heaper BLAST: #EmptyStepper]. ^myIndex! {Position} position myIndex >= myPastEnd ifTrue: [Heaper BLAST: #EmptyStepper]. ^myIndex integer! ! !PtrArrayStepper methodsFor: 'private: creation'! create: array {PtrArray} with: start {Int32} with: pastEnd {Int32} with: step {Int32} super create. myArray := array. myIndex := start. myPastEnd := pastEnd. myStep := step! ! !PtrArrayStepper methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myArray _ receiver receiveHeaper. myIndex _ receiver receiveInt32. myPastEnd _ receiver receiveInt32. myStep _ receiver receiveInt32.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myArray. xmtr sendInt32: myIndex. xmtr sendInt32: myPastEnd. xmtr sendInt32: myStep.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PtrArrayStepper class instanceVariableNames: ''! (PtrArrayStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !PtrArrayStepper class methodsFor: 'creation'! {TableStepper} ascending: array {PtrArray} "Note: this being a low level operation, and there being no lightweight form of immutable or lazily copied PtrArray, it is my caller's responsibility to pass me a PtrArray which will in fact not be changed during the life of this stepper. This is an unchecked an uncheckable precondition on my clients." ^self create: array with: Int32Zero with: array count with: 1! {TableStepper} descending: array {PtrArray} "Note: this being a low level operation, and there being no lightweight form of immutable or lazily copied PtrArray, it is my caller's responsibility to pass me a PtrArray which will in fact not be changed during the life of this stepper. This is an unchecked an uncheckable precondition on my clients." ^self create: array with: array count - 1 with: -1 with: -1! !Stepper subclass: #TupleStepper instanceVariableNames: ' mySpace {CrossSpace} myVirginSteppers {PtrArray of: (Stepper of: Position)} mySteppers {PtrArray of: (Stepper of: Position)} myLexOrder {PrimIntArray} myValue {Tuple | NULL}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-cross'! TupleStepper comment: 'A stepper for stepping through the positions in a simple cross region in order according to a lexicographic composition of OrderSpecs of each of the projections of the region. See CrossOrderSpec.NOT.A.TYPE '! (TupleStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !TupleStepper methodsFor: 'private: creation'! create: space {CrossSpace} with: virginSteppers {PtrArray of: (Stepper of: Position)} with: steppers {PtrArray of: (Stepper of: Position)} with: lexOrder {PrimIntArray} super create. mySpace := space. myVirginSteppers := virginSteppers. mySteppers := steppers. myLexOrder := lexOrder. self setValueFromSteppers! ! !TupleStepper methodsFor: 'private:'! {void} setValueFromSteppers | coords {PtrArray of: Position} | coords := PtrArray nulls: mySteppers count. Int32Zero almostTo: mySteppers count do: [:i {Int32} | coords at: i store: (((mySteppers fetch: i) cast: Stepper) get cast: Position)]. myValue := mySpace crossOfPositions: coords! ! !TupleStepper methodsFor: 'operations'! {Stepper} copy | newSteppers {PtrArray of: (Stepper of: Position)} | self hasValue ifFalse: [^Stepper emptyStepper]. newSteppers := PtrArray nulls: mySteppers count. Int32Zero almostTo: mySteppers count do: [:i {Int32} | newSteppers at: i store: ((mySteppers fetch: i) cast: Stepper) copy]. ^TupleStepper create: mySpace with: myVirginSteppers with: newSteppers with: myLexOrder! {Heaper wimpy} fetch ^myValue! {BooleanVar} hasValue ^myValue ~~ NULL! {void} step | stomp {Stepper of: Position} | myValue == NULL ifTrue: [^VOID]. myLexOrder count -1 to: Int32Zero by: -1 do: [:i {Int32} | | dim {Int32} | dim := (myLexOrder integerAt: i) DOTasLong. stomp := (mySteppers fetch: dim) cast: Stepper. stomp step. stomp hasValue ifTrue: [self setValueFromSteppers. ^VOID]. mySteppers at: dim store: ((myVirginSteppers fetch: dim) cast: Stepper) copy]. myValue := NULL! ! !TupleStepper methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. mySpace _ receiver receiveHeaper. myVirginSteppers _ receiver receiveHeaper. mySteppers _ receiver receiveHeaper. myLexOrder _ receiver receiveHeaper. myValue _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: mySpace. xmtr sendHeaper: myVirginSteppers. xmtr sendHeaper: mySteppers. xmtr sendHeaper: myLexOrder. xmtr sendHeaper: myValue.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TupleStepper class instanceVariableNames: ''! (TupleStepper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !TupleStepper class methodsFor: 'pseudoconstructors'! {Stepper} make: space {CrossSpace} with: virginSteppers {PtrArray of: (Stepper of: Position)} with: lexOrder {PrimIntArray default: NULL} | steppers {PtrArray of: (Stepper of: Position)} lexO {PrimIntArray} | virginSteppers count = Int32Zero ifTrue: [^Stepper itemStepper: (space crossOfPositions: (PtrArray nulls: Int32Zero))]. steppers := PtrArray nulls: virginSteppers count. Int32Zero almostTo: virginSteppers count do: [:i {Int32} | | vs {Stepper of: Position} | vs := (virginSteppers fetch: i) cast: Stepper. vs hasValue ifFalse: [^Stepper emptyStepper]. steppers at: i store: vs copy]. lexOrder == NULL ifTrue: [lexO := Int32Array make: virginSteppers count. Int32Zero almostTo: virginSteppers count do: [:i {Int32} | lexO at: i storeInteger: i]] ifFalse: [lexO := lexOrder]. ^self create: space with: virginSteppers with: steppers with: lexO! ! !TupleStepper class methodsFor: 'smalltalk: defaults'! make: space with: virginSteppers ^self make: space with: virginSteppers with: NULL! !Heaper subclass: #SuspendedHeaper instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-cache'! SuspendedHeaper comment: 'Heapers cached to avoid memory allocation overhead are kept as SuspendedHeapers to reduce GC overhead.'! (SuspendedHeaper getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; add: #NOT.A.TYPE; yourself)! !SuspendedHeaper methodsFor: 'creation'! {INLINE} create super create! ! !SuspendedHeaper methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! !Heaper subclass: #TableEntry instanceVariableNames: ' myNext {TableEntry} myValue {Heaper}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-SetTable'! (TableEntry getOrMakeCxxClassDescription) attributes: ((Set new) add: #EQ; add: #DEFERRED; add: #COPY; yourself)! !TableEntry methodsFor: 'accessing'! {TableEntry} copy self subclassResponsibility! {TableEntry INLINE | NULL} fetchNext ^myNext! {IntegerVar} index ^ (self position cast: IntegerPos) asIntegerVar! {BooleanVar} match: key {Position} "Return true if my key matches key." self subclassResponsibility! {BooleanVar} matchInt: index {IntegerVar} "Return true if my key matches the position associated with index." ^self match: index integer! {BooleanVar} matchValue: value {Heaper} "Return true if my value matches value. Note that this *must* test EQ first in case the value is no longer a heaper. Otherwise we could never remove a destructed object." ^value == (myValue basicCast: Heaper star) or: [value isEqual: myValue]! {Position} position self subclassResponsibility! {BooleanVar} replaceValue: newValue {Heaper} "Return true if my value can be replaced in place, and false if the entire entry must be replaced." "The default implementation." myValue _ newValue. ^true! {void INLINE} setNext: next {TableEntry | NULL} "Change my pointer to the rest of the chain in this bucket." myNext _ next! {Heaper INLINE} value ^myValue! ! !TableEntry methodsFor: 'protected: creation'! create: value {Heaper} super create. myNext _ NULL. myValue _ value! create: next {TableEntry} with: value {Heaper} super create. myNext _ next. myValue _ value! ! !TableEntry methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '(' << self position << ' -> ' << self value << ')'! ! !TableEntry methodsFor: 'destroy'! {void} destroy "temporarily don't destroy."! ! !TableEntry methodsFor: 'generated:'! actualHashForEqual ^self asOop! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myNext _ receiver receiveHeaper. myValue _ receiver receiveHeaper.! isEqual: other ^self == other! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myNext. xmtr sendHeaper: myValue.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TableEntry class instanceVariableNames: ''! (TableEntry getOrMakeCxxClassDescription) attributes: ((Set new) add: #EQ; add: #DEFERRED; add: #COPY; yourself)! !TableEntry class methodsFor: 'creation'! {TableStepper INLINE} bucketStepper: array {SharedPtrArray} ^BucketArrayStepper make: array! make.IntegerVar: index {IntegerVar} with: value {Heaper} index == value hashForEqual ifTrue: [^HashIndexEntry create: value] ifFalse: [^IndexEntry create: index with: value]! make: key {Position} with: value {Heaper} key cast: IntegerPos into: [:xuint | ^self make.IntegerVar: xuint asIntegerVar with: value] cast: HeaperAsPosition into: [:hap | (key isEqual: (HeaperAsPosition make: value)) ifTrue: [ ^HeaperAsEntry create: value] ifFalse: [^PositionEntry create: key with: value]] others: [^PositionEntry create: key with: value]. ^ NULL "compiler fodder"! !TableEntry subclass: #HashIndexEntry instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-SetTable'! (HashIndexEntry getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !HashIndexEntry methodsFor: 'accessing'! {BooleanVar} match: key {Position} "Return true if my key matches key." key cast: IntegerPos into: [:pos | ^pos asIntegerVar == self value hashForEqual] others: [^false]. ^ false "compiler fodder"! {BooleanVar} matchInt: index {IntegerVar} "Return true if my key matches the position associated with index." ^index == self value hashForEqual! {Position} position ^self value hashForEqual integer! {BooleanVar} replaceValue: newValue {Heaper} "Return true if my value can be replaced in place, and false if the entire entry must be replaced." ^newValue hashForEqual == self value hashForEqual and: [super replaceValue: newValue]! ! !HashIndexEntry methodsFor: 'creation'! {TableEntry} copy ^ HashIndexEntry create: self value! create: value {Heaper} super create: value! create: next {TableEntry} with: value {Heaper} super create: next with: value! ! !HashIndexEntry methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !TableEntry subclass: #HeaperAsEntry instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-SetTable'! (HeaperAsEntry getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !HeaperAsEntry methodsFor: 'accessing'! {BooleanVar} match: position {Position} "Return true if my position matches position." ^self position isEqual: position! {Position} position ^HeaperAsPosition make: self value! {BooleanVar} replaceValue: newValue {Heaper} "Return true if my value can be replaced in place, and false if the entire entry must be replaced." ^newValue hashForEqual == self value hashForEqual and: [super replaceValue: newValue]! ! !HeaperAsEntry methodsFor: 'creation'! {TableEntry} copy ^ HeaperAsEntry create: self value! create: value {Heaper} super create: value! create: next {TableEntry} with: value {Heaper} super create: next with: value! ! !HeaperAsEntry methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !TableEntry subclass: #IndexEntry instanceVariableNames: 'myIndex {IntegerVar}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-SetTable'! (IndexEntry getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !IndexEntry methodsFor: 'accessing'! {IntegerVar} index ^ myIndex! {BooleanVar} match: key {Position} "Return true if my key matches key." key cast: IntegerPos into: [:pos | ^pos asIntegerVar == myIndex] others: [^false]. ^ false "compiler fodder"! {BooleanVar} matchInt: index {IntegerVar} "Return true if my key matches the position associated with index." ^index == myIndex! {Position} position ^myIndex integer! ! !IndexEntry methodsFor: 'creation'! {TableEntry} copy ^ IndexEntry create: myIndex with:self value! create: index {IntegerVar} with: value {Heaper} super create: value. myIndex _ index! create: next {TableEntry} with: value {Heaper} with: index {IntegerVar} super create: next with: value. myIndex _ index! ! !IndexEntry methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '(' << myIndex integer << ' -> ' << self value << ')'! ! !IndexEntry methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myIndex _ receiver receiveIntegerVar.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendIntegerVar: myIndex.! !TableEntry subclass: #PositionEntry instanceVariableNames: 'myKey {Position}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-SetTable'! (PositionEntry getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !PositionEntry methodsFor: 'accessing'! {BooleanVar} match: key {Position} "Return true if my key matches key." ^key isEqual: myKey! {Position} position ^myKey! ! !PositionEntry methodsFor: 'creation'! {TableEntry} copy ^ PositionEntry create: myKey with: self value! create: key {Position} with: value {Heaper} super create: value. myKey _ key! create: next {TableEntry} with: value {Heaper} with: key {Position} super create: next with: value. myKey _ key! ! !PositionEntry methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myKey _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myKey.! !Heaper subclass: #Thunk instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FM-Support'! Thunk comment: 'Thunk is the abstraction for reified void/0-argument operations. Therse include Testers, frontend operations, etc.'! (Thunk getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #EQ; yourself)! !Thunk methodsFor: 'operate'! {void} execute "Execute the action defined by this thunk." self subclassResponsibility! ! !Thunk methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! !Thunk subclass: #BootPlan instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-cobbler'! (BootPlan getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !BootPlan methodsFor: 'accessing'! {Category} bootCategory self subclassResponsibility! {Connection} connection "Return the object representing the connection. This gives the client a handle by which to terminate the connection." self subclassResponsibility! ! !BootPlan methodsFor: 'operate'! {void} execute "A comm hook couldn't register the bootPlan because it's working with a not-fully constructed object, so we have to make bootPlans thunks and register them here." Connection registerBootPlan: self! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BootPlan class instanceVariableNames: ''! (BootPlan getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !BootPlan class methodsFor: 'smalltalk: init'! cleanupGarbage BootCuisine _ NULL! initTimeNonInherited Cookbook declareCookbook: 'boot' with: BootPlan with: BootCuisine with: XppCuisine! linkTimeNonInherited Recipe star defineGlobal: #BootCuisine with: NULL.! !BootPlan subclass: #BootMaker instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-cobbler'! (BootMaker getOrMakeCxxClassDescription) attributes: ((Set new) add: #NOT.A.TYPE; add: #DEFERRED; yourself)! !BootMaker methodsFor: 'accessing'! {Category} bootCategory self subclassResponsibility! {Connection} connection "Return the object representing the connection. This gives the client a handle by which to terminate the connection." ^DirectConnection create: self bootCategory with: self bootHeaper! ! !BootMaker methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name.! ! !BootMaker methodsFor: 'protected:'! {Heaper} bootHeaper "Subclasses of maker only need to define the routine that makes the boot heaper." self subclassResponsibility! !BootMaker subclass: #BackendBootMaker instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-fbtest'! (BackendBootMaker getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); add: #NOT.A.TYPE; yourself)! !BackendBootMaker methodsFor: 'accessing'! {Category} bootCategory ^BeGrandMap! ! !BackendBootMaker methodsFor: 'protected:'! {Heaper} bootHeaper ^BeGrandMap make! ! !BackendBootMaker methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BackendBootMaker class instanceVariableNames: ''! (BackendBootMaker getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); add: #NOT.A.TYPE; yourself)! !BackendBootMaker class methodsFor: 'creation'! {BootPlan} make ^self create! ! !BackendBootMaker class methodsFor: 'smalltalk: init'! initTimeNonInherited [FeServer, Recipe] USES. Cookbook declareCookbook: 'disk' with: BeGrandMap with: DiskCuisine with: XppCuisine with: FebeCuisine! !BootMaker subclass: #HonestAbePlan instanceVariableNames: 'myCategory {Category}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-packer'! (HonestAbePlan getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); add: #NOT.A.TYPE; yourself)! !HonestAbePlan methodsFor: 'accessing'! {Category} bootCategory ^myCategory! {Heaper} bootHeaper ^CurrentPacker fluidGet getInitialFlock bootHeaper! ! !HonestAbePlan methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myCategory _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myCategory.! !BootMaker subclass: #ShepherdBootMaker instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-fbtest'! (ShepherdBootMaker getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); add: #NOT.A.TYPE; yourself)! !ShepherdBootMaker methodsFor: 'accessing'! {Category} bootCategory ^Counter! ! !ShepherdBootMaker methodsFor: 'protected:'! {Heaper} bootHeaper ^Counter make.! ! !ShepherdBootMaker methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ShepherdBootMaker class instanceVariableNames: ''! (ShepherdBootMaker getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); add: #NOT.A.TYPE; yourself)! !ShepherdBootMaker class methodsFor: 'creation'! {BootPlan} make ^self create! !BootMaker subclass: #WorksBootMaker instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-fbtest'! (WorksBootMaker getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); add: #NOT.A.TYPE; yourself)! !WorksBootMaker methodsFor: 'accessing'! {Category} bootCategory ^FeServer! ! !WorksBootMaker methodsFor: 'protected:'! {Heaper} bootHeaper GrandConnection fluidFetch == NULL ifTrue: ["CurrentGrandMap fluidFetch == NULL ifFalse: [Heaper BLAST: #GrandMapWithoutConnection]." GrandConnection fluidSet: (Connection make: BeGrandMap). CurrentGrandMap fluidSet: (GrandConnection fluidGet bootHeaper cast: BeGrandMap). "force agenda items to be invoked - they were commented out in getInitialFlock /ravi/10/22/92/" DiskManager consistent: []]. ^FeServer make! ! !WorksBootMaker methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! WorksBootMaker class instanceVariableNames: ''! (WorksBootMaker getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); add: #NOT.A.TYPE; yourself)! !WorksBootMaker class methodsFor: 'smalltalk: init'! staticTimeNonInherited Connection defineFluid: #GrandConnection with: Emulsion globalEmulsion with: [NULL].! !BootPlan subclass: #ClearPlan instanceVariableNames: 'myCategory {Category}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-cobbler'! ClearPlan comment: 'Remove a particular entry from the table of current BootPlans.'! (ClearPlan getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); add: #NOT.A.TYPE; yourself)! !ClearPlan methodsFor: 'accessing'! {Category} bootCategory ^myCategory! {Connection} connection "Return the object representing the connection. This gives the client a handle by which to terminate the connection." Heaper BLAST: #NoBootPlan. ^NULL "fodder"! ! !ClearPlan methodsFor: 'operate'! {void} execute "Use this hook to clear the element out of the bootPlan registration table." Connection clearPlan: myCategory! ! !ClearPlan methodsFor: 'creation'! create: cat {Category} super create. myCategory _ cat! ! !ClearPlan methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myCategory _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myCategory.! !BootPlan subclass: #FeWorksBootMaker instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-fbtest'! (FeWorksBootMaker getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); add: #NOT.A.TYPE; yourself)! !FeWorksBootMaker methodsFor: 'accessing'! {Category} bootCategory ^ FeServer! {Connection} connection | conn {Connection} | conn _ Connection make: FeServer. ^ conn "^NestedConnection make: self bootCategory with: (PrGateKeeper make: (conn bootHeaper cast: FeGateKeeper)) with: conn"! ! !FeWorksBootMaker methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !BootPlan subclass: #FromDiskPlan instanceVariableNames: ' myCategory {Category} myFilename {Character star}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-cobbler'! FromDiskPlan comment: 'Instances of this represent the plan for getting a particular kind of object from an urdi on a particular file. They open the urdi, create a packer, retrieve the Turtle from the packer, and pull out the boot object.'! (FromDiskPlan getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); add: #NOT.A.TYPE; yourself)! !FromDiskPlan methodsFor: 'accessing'! {Category} bootCategory ^myCategory! {Connection} connection "Return the object representing the connection. This gives the client a handle by which to terminate the connection." DiskManager make: myFilename. ^DiskConnection create: self bootCategory with: CurrentPacker fluidGet getInitialFlock bootHeaper! ! !FromDiskPlan methodsFor: 'creation'! create: cat {Category} with: filename {Character star} super create. myCategory _ cat. myFilename _ filename! ! !FromDiskPlan methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myCategory _ receiver receiveHeaper. myFilename _ receiver receiveString.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myCategory. xmtr sendString: myFilename.! !BootPlan subclass: #TrackCBlocks instanceVariableNames: 'myBootPlan {BootPlan}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-calc'! (TrackCBlocks getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); add: #NOT.A.TYPE; yourself)! !TrackCBlocks methodsFor: 'accessing'! {Category} bootCategory ^myBootPlan bootCategory! {Connection} connection "Return the object representing the connection. This gives the client a handle by which to terminate the connection." | result {Connection} | result _ myBootPlan connection. CurrentPacker fluidSet: (CBlockTrackingPacker make: CurrentPacker fluidGet). ^result! ! !TrackCBlocks methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myBootPlan _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myBootPlan.! !Thunk subclass: #CommentThunk instanceVariableNames: 'message {char star}' classVariableNames: '' poolDictionaries: '' category: 'Cxx-class-other'! (CommentThunk getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !CommentThunk methodsFor: 'hooks:'! {void} restartCommentThunk: rcvr {Rcvr unused default: NULL} DeleteExecutor registerHolder: self with: message.! ! !CommentThunk methodsFor: 'action'! {void} execute! ! !CommentThunk methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. message _ receiver receiveString.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendString: message.! !Thunk subclass: #DiskIniter instanceVariableNames: ' myCategory {Category} myFilename {char star} mySnarfSize {Int32 NOCOPY} mySnarfCount {Int32 NOCOPY} myStageCount {Int32 NOCOPY}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Xcvr'! (DiskIniter getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); add: #NOT.A.TYPE; yourself)! !DiskIniter methodsFor: 'running'! {void} execute | maker {XcvrMaker} cookbook {Cookbook} turtle {Turtle} conn {Connection} | DiskManager initializeDisk: myFilename. maker _ ProtocolBroker diskProtocol. cookbook _ Cookbook make.Category: myCategory. turtle _ Turtle make: cookbook with: myCategory with: maker. conn _ Connection make: myCategory. turtle saveBootHeaper: conn bootHeaper. (conn bootHeaper cast: BeGrandMap) bePurgeable. CurrentPacker fluidGet purge. "Let's make sure that the GC gets as much as possible." "[WorksBootMaker] USES. GrandConnection fluidSet: NULL." conn _ NULL. turtle _ NULL. maker _ NULL. cookbook _ NULL. CurrentPacker fluidGet destroy. CurrentPacker fluidSet: (NULL basicCast: DiskManager).! ! !DiskIniter methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myCategory _ receiver receiveHeaper. myFilename _ receiver receiveString.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myCategory. xmtr sendString: myFilename.! !Thunk subclass: #DiskPurgeRate instanceVariableNames: 'myCount {IntegerVar}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Snarf'! DiskPurgeRate comment: 'Set the number of GCs between purges of the packer.'! (DiskPurgeRate getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); add: #NOT.A.TYPE; yourself)! !DiskPurgeRate methodsFor: 'operate'! {void} execute "Set the number of GCs between packer purges." Purgeror setPurgeRate: myCount! ! !DiskPurgeRate methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myCount _ receiver receiveIntegerVar.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendIntegerVar: myCount.! !Thunk subclass: #EchoThunk instanceVariableNames: 'message {char star}' classVariableNames: '' poolDictionaries: '' category: 'Cxx-class-other'! (EchoThunk getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !EchoThunk methodsFor: 'action'! {void} execute "Execute the action defined by this thunk." cerr << message << ' '! ! !EchoThunk methodsFor: 'hooks:'! {void} restartEchoThunk: rcvr {Rcvr unused default: NULL} DeleteExecutor registerHolder: self with: message! ! !EchoThunk methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. message _ receiver receiveString.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendString: message.! !Thunk subclass: #FakeDisk instanceVariableNames: 'myCategory {Category}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Xcvr'! (FakeDisk getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); add: #NOT.A.TYPE; yourself)! !FakeDisk methodsFor: 'running'! {void} execute FakePacker make. MockTurtle make: myCategory.! ! !FakeDisk methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myCategory _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myCategory.! !Thunk subclass: #HonestAbeIniter instanceVariableNames: ' myCategory {Category} blastOnError {BooleanVar} persistInterval {IntegerVar}' classVariableNames: ' TheHonestConnection {Connection} TheHonestGrandMap {BeGrandMap} ' poolDictionaries: '' category: 'Xanadu-diskman'! (HonestAbeIniter getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); add: #NOT.A.TYPE; yourself)! !HonestAbeIniter methodsFor: 'running'! {void} execute | cookbook {Cookbook} turtle {Turtle} conn {Connection} | TestPacker make: blastOnError with: persistInterval. cookbook := Cookbook make.Category: myCategory. turtle := Turtle make: cookbook with: myCategory with: ProtocolBroker diskProtocol. conn := Connection make: myCategory. TheHonestConnection _ conn. turtle saveBootHeaper: conn bootHeaper. "The following is here so that later thunks can get the GrandMap &c" "[WorksBootMaker] USES. GrandConnection fluidSet: TheHonestConnection.ó" TheHonestGrandMap _ conn bootHeaper cast: BeGrandMap. CurrentPacker fluidGet purge. "CurrentPacker fluidSet: NULL. "! ! !HonestAbeIniter methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myCategory _ receiver receiveHeaper. blastOnError _ receiver receiveBooleanVar. persistInterval _ receiver receiveIntegerVar.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myCategory. xmtr sendBooleanVar: blastOnError. xmtr sendIntegerVar: persistInterval.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HonestAbeIniter class instanceVariableNames: ''! (HonestAbeIniter getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); add: #NOT.A.TYPE; yourself)! !HonestAbeIniter class methodsFor: 'accessing'! {BeGrandMap} fetchGrandMap ^ TheHonestGrandMap! ! !HonestAbeIniter class methodsFor: 'smalltalk: init'! exitTimeNonInherited TheHonestConnection _ NULL! linkTimeNonInherited TheHonestConnection _ NULL. TheHonestGrandMap _ NULL.! !Thunk subclass: #Honestly instanceVariableNames: ' myCategory {Category} blastOnError {BooleanVar} persistInterval {IntegerVar}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-diskman'! (Honestly getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); add: #NOT.A.TYPE; yourself)! !Honestly methodsFor: 'running'! {void} execute CurrentPacker fluidFetch == NULL ifTrue: [TestPacker make: blastOnError with: persistInterval. Turtle make: NULL with: myCategory with: ProtocolBroker diskProtocol]. CurrentGrandMap fluidSet: HonestAbeIniter fetchGrandMap.! ! !Honestly methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myCategory _ receiver receiveHeaper. blastOnError _ receiver receiveBooleanVar. persistInterval _ receiver receiveIntegerVar.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myCategory. xmtr sendBooleanVar: blastOnError. xmtr sendIntegerVar: persistInterval.! !Thunk subclass: #PrintCBlocksTracks instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-calc'! (PrintCBlocksTracks getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); add: #NOT.A.TYPE; yourself)! !PrintCBlocksTracks methodsFor: 'operate'! {void} execute "" "PrintCBlocksTracks create execute" CBlockTracker printTrackersOn: cerr. [cerr endEntry] smalltalkOnly! ! !PrintCBlocksTracks methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !Thunk subclass: #ServerLoop instanceVariableNames: ' myCategory {Category} myActiveChunks {MuSet NOCOPY of: ServerChunk} myTerminateFlag {BooleanVar NOCOPY} myStepper {Stepper NOCOPY}' classVariableNames: ' MyServerLoopInstance {ServerLoop} TheChunks {MuSet of: ServerChunk} ' poolDictionaries: '' category: 'Xanadu-rcmain'! ServerLoop comment: ' This is the superclass of all server loops. There is only one instance of this class in any backend. Its execute method is the central backend processing loop. When an instance is created, its creation method must register it with this class. At that time, all listeners that have been created up to this point will be passed to the new server loop instance. After this time, new listeners will be passed to the serverloop instance as they register themselves with this class. '! (ServerLoop getOrMakeCxxClassDescription) friends: '/* friends for class ServerLoop */ friend class TerminateTest; friend void registerChunk (APTR(ServerChunk) aChunk); friend void registerServerLoop (APTR(ServerLoop) aLoop); friend void removeChunk (APTR(ServerChunk) aChunk); friend void scheduleTermination (); '; attributes: ((Set new) add: #(COPY boot ); add: #DEFERRED; yourself)! !ServerLoop methodsFor: 'protected: accessing'! {MuSet of: ServerChunk} activeChunks ^myActiveChunks! {void} deregisterChunk: aChunk {ServerChunk} "subclasses should call me too" myActiveChunks wipe: aChunk! {void} registerChunk: aChunk {ServerChunk} "subclass must call this one first" aChunk execute ifTrue: [myActiveChunks store: aChunk]! {void} setTerminate: toBoolean {BooleanVar} myTerminateFlag _ toBoolean! {Stepper} stepper ^ myStepper! {void} stepper: stepper {Stepper} myStepper := stepper! {BooleanVar} terminate ^ myTerminateFlag! ! !ServerLoop methodsFor: 'execution'! {void} execute | deadLoop {ServerLoop} | CurrentServerLoop fluidBind: self during: [CurrentServerConnection fluidBind: (Connection make: myCategory) during: [CurrentServerConnection fluidGet bootHeaper. ServerLoop registerServerLoop: self. [CurrentServerLoop fluidGet terminate] whileFalse: [CurrentServerLoop fluidGet stepper: CurrentServerLoop fluidGet activeChunks stepper. [CurrentServerLoop fluidGet stepper hasValue] whileTrue: [ | chunk {ServerChunk} | chunk := CurrentServerLoop fluidGet stepper fetch cast: ServerChunk. chunk execute ifFalse: [ CurrentServerLoop fluidGet activeChunks remove: chunk. chunk shouldDestroy ifTrue: [chunk destroy]]. Heaplet garbageCollect. RepairEngineer repairThings. CurrentServerLoop fluidGet stepper step]. CurrentServerLoop fluidGet stepper: NULL. CurrentServerLoop fluidGet scheduleChunks]. TheChunks stepper forEach: [:c {ServerChunk} | c destroy]. deadLoop _ ServerLoop removeServerLoop. ((deadLoop basicCast: Heaper star) ~= CurrentServerLoop fluidGet) ifTrue: [Heaper BLAST: #WRONG.U.SERVERLOOP]]. CurrentServerConnection fluidGet destroy. CurrentServerLoop fluidGet destroy].! {void} scheduleChunks "Schedule any chunks that have bnecome active." self subclassResponsibility! ! !ServerLoop methodsFor: 'creation'! create super create. self restartServerLoop: NULL.! ! !ServerLoop methodsFor: 'hooks:'! {void RECEIVE.HOOK} restartServerLoop: rcvr {Rcvr unused} myTerminateFlag _ false. myActiveChunks := MuSet make. myStepper _ NULL.! ! !ServerLoop methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myCategory _ receiver receiveHeaper. self restartServerLoop: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myCategory.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ServerLoop class instanceVariableNames: ''! (ServerLoop getOrMakeCxxClassDescription) friends: '/* friends for class ServerLoop */ friend class TerminateTest; friend void registerChunk (APTR(ServerChunk) aChunk); friend void registerServerLoop (APTR(ServerLoop) aLoop); friend void removeChunk (APTR(ServerChunk) aChunk); friend void scheduleTermination (); '; attributes: ((Set new) add: #(COPY boot ); add: #DEFERRED; yourself)! !ServerLoop class methodsFor: 'smalltalk: init'! cleanupGarbage TheChunks == NULL ifTrue: [^ VOID]. TheChunks stepper forEach: [:chunk {ServerChunk} | chunk destroy]. TheChunks destroy. TheChunks _ NULL. MyServerLoopInstance _ NULL! initTimeNonInherited self REQUIRES: MuSet. TheChunks _ MuSet make.! linkTimeNonInherited MyServerLoopInstance _ NULL. TheChunks _ NULL! staticTimeNonInherited Connection defineFluid: #CurrentServerConnection with: Emulsion globalEmulsion with: [NULL]. ServerLoop defineFluid: #CurrentServerLoop with: Emulsion globalEmulsion with: [NULL].! ! !ServerLoop class methodsFor: 'protected: accessing'! {MuSet of: ServerChunk} chunks ^TheChunks! ! !ServerLoop class methodsFor: 'accessing'! {ServerLoop} currentServerLoop ^ MyServerLoopInstance! {void} introduceChunk: aChunk {ServerChunk} TheChunks introduce: aChunk. MyServerLoopInstance ~~ NULL ifTrue: [MyServerLoopInstance registerChunk: aChunk]! {void} registerServerLoop: aLoop {ServerLoop} MyServerLoopInstance ~~ NULL ifTrue: [Heaper BLAST: #CANNOT.U.HAVE.U.MULTIPLE.U.SERVER.U.LOOPS]. MyServerLoopInstance _ aLoop. TheChunks stepper forEach: [:chunk {ServerChunk} | MyServerLoopInstance registerChunk: chunk]! {void} removeChunk: aChunk {ServerChunk} TheChunks wipe: aChunk. MyServerLoopInstance ~~ NULL ifTrue: [MyServerLoopInstance deregisterChunk: aChunk]! {ServerLoop} removeServerLoop | oldLoop {ServerLoop} | (MyServerLoopInstance == NULL) ifTrue: [Heaper BLAST: #SERVERLOOP.U.IS.U.NULL. ^ NULL]. oldLoop _ MyServerLoopInstance. MyServerLoopInstance _ NULL. ^ oldLoop! {void} scheduleTermination self currentServerLoop setTerminate: true! !ServerLoop subclass: #SelectServerLoop instanceVariableNames: 'myFDSet {fd.U.set var NOCOPY}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-rcmain'! SelectServerLoop comment: 'This is a ServerLoop designed specifically for Berkeley Sockets. It allows socket listeners to be registered and it dispatches among them based on a select() call'! (SelectServerLoop getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); add: #NOT.A.TYPE; yourself)! !SelectServerLoop methodsFor: 'creation'! create super create. ' #ifndef HIGHC FD_ZERO(&myFDSet); #endif' translateOnly! ! !SelectServerLoop methodsFor: 'execution'! {void} scheduleChunks "Schedule any chunks that have become active." [Stepper] USES. [MuSet] USES. [Delay forMilliseconds: 100.] smalltalkOnly. ' #ifdef unix signal (SIGPIPE, SIG_IGN); #endif static fd_set readfds = myFDSet; static fd_set exceptfds = myFDSet; #if defined(unix) && !! defined(__sgi) int maxFDs = getdtablesize(); #else int maxFDs = FD_SETSIZE; #endif /* unix */ int numReady; if (this->activeChunks ()->isEmpty ()) { numReady = select (maxFDs-1, &readfds, NULL, &exceptfds, NULL); } else { /* timeout immediately so active Chunks can execute */ timeval zero; zero.tv_sec = 0; zero.tv_usec = 0; numReady = select (maxFDs-1, &readfds, NULL, &exceptfds, &zero); } if (numReady <= 0 ) { #ifdef WIN32 if (numReady == 0 || errno == WSAEINTR) { #else if (numReady == 0 || errno == EINTR) { #endif /* WIN32 */ return; } BLAST(SELECT_FAILED); } BEGIN_FOR_EACH(FDListener, aListener, (ServerLoop::chunks()->stepper())) { if (FD_ISSET(aListener->descriptor(), &exceptfds)) { ServerLoop::chunks()->remove(aListener); aListener->destroy (); if (--numReady <= 0) break; } else if (FD_ISSET(aListener->descriptor(), &readfds)) { if (aListener->shouldBeReady ()) { this->activeChunks()->store(aListener); } else { ServerLoop::chunks()->remove(aListener); aListener->destroy (); } if (--numReady <= 0) break; } } END_FOR_EACH; ' translateOnly. [self activeChunks storeAll: ServerLoop chunks. Processor yield] smalltalkOnly! ! !SelectServerLoop methodsFor: 'protected: accessing'! {void} deregisterChunk: aChunk {ServerChunk} super deregisterChunk: aChunk. ' FD_CLR(CAST(FDListener,aChunk)->descriptor(), &myFDSet); ' translateOnly! {void} registerChunk: aChunk {ServerChunk} super registerChunk: aChunk. ' FD_SET(CAST(FDListener,aChunk)->descriptor(), &myFDSet); ' translateOnly! ! !SelectServerLoop methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! SelectServerLoop class instanceVariableNames: ''! (SelectServerLoop getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); add: #NOT.A.TYPE; yourself)! !SelectServerLoop class methodsFor: 'creation'! {Thunk} make ^ self create! !Thunk subclass: #SetCommProtocol instanceVariableNames: 'myName {char star}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-rcmain'! SetCommProtocol comment: 'When executed, the receiver will set the comm protocol for the next connection.'! (SetCommProtocol getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); add: #NOT.A.TYPE; yourself)! !SetCommProtocol methodsFor: 'hooks:'! {void} restartSetCommProtocol: rcvr {Rcvr unused default: NULL} DeleteExecutor registerHolder: self with: myName! ! !SetCommProtocol methodsFor: 'thunking'! {void} execute "Execute the action defined by this thunk." ProtocolBroker setCommProtocol: (ProtocolBroker commProtocol: myName)! ! !SetCommProtocol methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myName _ receiver receiveString.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendString: myName.! !Thunk subclass: #SetDiskProtocol instanceVariableNames: 'myName {char star}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-rcmain'! SetDiskProtocol comment: 'When executed, the receiver will set the disk protocol for the next connection.'! (SetDiskProtocol getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); add: #NOT.A.TYPE; yourself)! !SetDiskProtocol methodsFor: 'operate'! {void} execute "Execute the action defined by this thunk." ProtocolBroker setDiskProtocol: (ProtocolBroker diskProtocol: myName)! ! !SetDiskProtocol methodsFor: 'hooks:'! {void} restartSetDiskProtocol: rcvr {Rcvr unused default: NULL} DeleteExecutor registerHolder: self with: myName! ! !SetDiskProtocol methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myName _ receiver receiveString.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendString: myName.! !Thunk subclass: #SnarfStatistics instanceVariableNames: ' myFilename {char star} myCookbook {Cookbook NOCOPY} myProtocol {XcvrMaker NOCOPY}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-snfinfo'! SnarfStatistics comment: 'Print out some summary of the data currently on disk.'! (SnarfStatistics getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); add: #NOT.A.TYPE; yourself)! !SnarfStatistics methodsFor: 'running'! {void} execute self snarfAllocInfo. self tallyFlockTypes.! {void} snarfAllocInfo | anUrdi {Urdi} view {UrdiView} info {SnarfInfoHandler} totalReal {IntegerVar} totalForget {IntegerVar} totalRealSpace {IntegerVar} totalForgetSpace {IntegerVar} | totalReal _ IntegerVarZero. totalForget _ IntegerVarZero. totalRealSpace _ IntegerVarZero. totalForgetSpace _ IntegerVarZero. anUrdi _ (Urdi urdi: myFilename with: 2). view _ anUrdi makeReadView. info _ SnarfInfoHandler make: anUrdi with: view. cerr << 'There are ' << info snarfInfoCount << ' snarFInfo snarfs out of ' << info snarfCount << ' total snarfs. There are ' << (view getDataSizeOfSnarf: 1) << ' bytes in each snarf. '. info snarfInfoCount almostTo: info snarfCount do: [:snarfID {Int32} | (info getSpaceLeft: snarfID) < (view getDataSizeOfSnarf: snarfID) ifTrue: [| handler {SnarfHandler} count {Int32} forwards {Int32} forgets {Int32} forgetSpace {Int32} flocks {Int32} liveSpace {Int32} | handler _ SnarfHandler make: (view makeReadHandle: snarfID). count _ handler mapCount. forwards _ forgets _ forgetSpace _ flocks _ liveSpace _ Int32Zero. Int32Zero almostTo: count do: [:i {Int32} | (handler isOccupied: i) ifTrue: [(handler fetchForward: i) ~~ NULL ifTrue: [forwards _ forwards + 1] ifFalse: [(handler isForgotten: i) ifTrue: [forgets _ forgets + 1. forgetSpace _ forgetSpace + (handler flockSize: i)] ifFalse: [flocks _ flocks + 1. liveSpace _ liveSpace + (handler flockSize: i)]]]]. cerr << snarfID << ': ' << flocks << ' real in ' << liveSpace << ' bytes. '. cerr << forgets << ' forgets in ' << forgetSpace << ' bytes. '. cerr << forwards << ' forward. '. cerr "<< count << ' cells '" << handler spaceLeft << ' spaceLeft.'. cerr << ' forgotten: ' << (info getForgottenFlag: snarfID) << '. '. handler destroy. totalReal _ totalReal + flocks. totalRealSpace _ totalRealSpace + liveSpace. totalForget _ totalForget + forgets. totalForgetSpace _ totalForgetSpace + forgetSpace]]. cerr << 'All others empty. '. cerr << 'Totals: ' << totalReal << ' real in ' << totalRealSpace << ' bytes, ' << totalForget << ' forgets in ' << totalForgetSpace << ' bytes. '. info destroy. view destroy. anUrdi destroy! {void} tallyFlockTypes | anUrdi {Urdi} view {UrdiView} info {SnarfInfoHandler} liveFlockCounts {PrimIndexTable} liveFlockTypes {PrimPtr2PtrTable} forgottenFlockCounts {PrimIndexTable} forgottenFlockTypes {PrimPtr2PtrTable} | liveFlockCounts _ PrimIndexTable make: 255. liveFlockTypes _ PrimPtr2PtrTable make: 255. forgottenFlockCounts _ PrimIndexTable make: 255. forgottenFlockTypes _ PrimPtr2PtrTable make: 255. anUrdi _ Urdi urdi: myFilename with: 2. view _ anUrdi makeReadView. info _ SnarfInfoHandler make: anUrdi with: view. self diskCookbook: view with: info. cerr << 'Tallying types over all snarfs, this may take a while. '. info snarfInfoCount almostTo: info snarfCount do: [:snarfID {Int32} | (info getSpaceLeft: snarfID) < (view getDataSizeOfSnarf: snarfID) ifTrue: [| handler {SnarfHandler} count {Int32} | handler _ SnarfHandler make: (view makeReadHandle: snarfID). count _ handler mapCount. Int32Zero almostTo: count do: [:i {Int32} | ((handler isOccupied: i) and: [(handler fetchForward: i) == NULL]) ifTrue: [| rcvr {Rcvr} stream {XnReadStream} cat {Category} | rcvr _ self makeRcvr: (stream _ handler readStream: i). cat _ SpecialistRcvrJig receiveCategory: rcvr. rcvr destroy. stream destroy. (cat isEqualOrSubclassOf: Abraham) ifFalse: [cerr << 'WARNING: non-Abraham flock at ' << snarfID << ':' << i << ' : '. cerr << cat name << ' '. cerr << ' flock size = ' << (handler flockSize: i) << ' ']. (handler isForgotten: i) ifFalse: [(liveFlockTypes fetch: cat) == NULL ifTrue: [liveFlockTypes at: cat store: cat. liveFlockCounts at: cat store: 1] ifFalse: [liveFlockCounts at: cat store: (liveFlockCounts fetch: cat) + 1]] ifTrue: [(forgottenFlockTypes fetch: cat) == NULL ifTrue: [forgottenFlockTypes at: cat store: cat. forgottenFlockCounts at: cat store: 1] ifFalse: [forgottenFlockCounts at: cat store: (forgottenFlockCounts fetch: cat) + 1]]]]. handler destroy]]. cerr << ' tally of live flocks. '. liveFlockTypes stepper forEach: [:cat {Category} | cerr << (liveFlockCounts fetch: cat) << ' ' << cat name << ' ']. cerr << ' tally of forgotten flocks. '. forgottenFlockTypes stepper forEach: [:cat {Category} | cerr << (forgottenFlockCounts fetch: cat) << ' ' << cat name << ' ']. info destroy. view destroy. anUrdi destroy! ! !SnarfStatistics methodsFor: 'private'! {void} diskCookbook: view {UrdiView} with: info {SnarfInfoHandler} "Get the cookbook and protocol-stream maker for the disk." | handler {SnarfHandler} stream {XnReadStream} rcvr {Rcvr} protocol {char star} cookbook {char star}| handler _ SnarfHandler make: (view makeReadHandle: info snarfInfoCount). rcvr _ TextyXcvrMaker makeReader: (stream _ handler readStream: Int32Zero). protocol _ rcvr receiveString. cookbook _ rcvr receiveString. rcvr destroy. stream destroy. handler destroy. myProtocol _ ProtocolBroker diskProtocol: protocol. myCookbook _ Cookbook make.String: cookbook. protocol delete. cookbook delete.! {SpecialistRcvr} makeRcvr: readStream {XnReadStream} ^myProtocol makeRcvr: (DiskSpecialist make: myCookbook with: NULL) with: readStream! ! !SnarfStatistics methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myFilename _ receiver receiveString.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendString: myFilename.! !Thunk subclass: #SpareStageSpace instanceVariableNames: ' myCruftedSnarfCount {Int32} myFlocksPerSnarf {Int32}' classVariableNames: ' CruftedSnarfCount {Int32} FlocksPerSnarf {Int32} ' poolDictionaries: '' category: 'Xanadu-packer'! (SpareStageSpace getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); yourself)! !SpareStageSpace methodsFor: 'execute'! {void} execute CruftedSnarfCount := myCruftedSnarfCount. FlocksPerSnarf := myFlocksPerSnarf.! ! !SpareStageSpace methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myCruftedSnarfCount _ receiver receiveInt32. myFlocksPerSnarf _ receiver receiveInt32.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendInt32: myCruftedSnarfCount. xmtr sendInt32: myFlocksPerSnarf.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! SpareStageSpace class instanceVariableNames: ''! (SpareStageSpace getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); yourself)! !SpareStageSpace class methodsFor: 'smalltalk: init'! linkTimeNonInherited CruftedSnarfCount := 7. FlocksPerSnarf := 100.! ! !SpareStageSpace class methodsFor: 'accessing'! {Int32} cruftedSnarfsGuess ^ CruftedSnarfCount! {Int32} flocksPerSnarfGuess ^ FlocksPerSnarf! !Thunk subclass: #SwitchLogger instanceVariableNames: ' myLoggerName {char star} myDirective {char star}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-hlogger'! (SwitchLogger getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !SwitchLogger methodsFor: 'operate'! {void} execute (Logger get: myLoggerName) init: myDirective! ! !SwitchLogger methodsFor: 'hooks:'! {void} restartSwitchLogger: rcvr {Rcvr unused default: NULL} DeleteExecutor registerHolder: self with: myLoggerName. DeleteExecutor registerHolder: self with: myDirective.! ! !SwitchLogger methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myLoggerName _ receiver receiveString. myDirective _ receiver receiveString.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendString: myLoggerName. xmtr sendString: myDirective.! !Thunk subclass: #Tester instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Testing'! Tester comment: 'Testers are for controlling the running of regression tests. See "Regression Testing Procedures and Recommendations".'! (Tester getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !Tester methodsFor: 'testing'! {void} allTestsOn: oo {ostream reference} "A regression test is run by calling this method. What the tester writes to 'oo' is actually written to file *o.txt and compared against an approved reference file (*r.txt) of what this tester once used to output. If they match exactly, then the test is passed. Otherwise, someone needs to manually understand why they're different. The diff is in file *d.txt. It is strongly recommended (in order to avoid regression errors) that when a tester is extended to test something new that its output also be extended with some result of the new test. The extended test will then fail the first time. The programmer should verify that the reason for failure is exactly that the tester now additionally outputs the correct results of the new test, in which case this output should be made into the new reference output and the test run again." self subclassResponsibility! ! !Tester methodsFor: 'running'! {void} execute "The receiver reacts to the key and value (tested my matches:with:), execute it." [self allTestsOn: cerr] translateOnly. [self allTestsOn: cerr] smalltalkOnly. "[| str {Stream of: char} time {IntegerVar} | str _ WriteStream on: (String new: 200). time _ Time millisecondsToRun: [self allTestsOn: str]. Transcript cr; nextPutAll: str contents. Transcript << 'Run Time = ' ; << time; show: ' ms '. ] smalltalkOnly"! ! !Tester methodsFor: 'creation'! create super create! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Tester class instanceVariableNames: ''! (Tester getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !Tester class methodsFor: 'accessing'! {Tester} fetchTester: tName {char star} "Returns the tester whose name is 'tName'. NULL if none." self unimplemented. ^NULL "fodder" "Testers stepper forEach: [:tester {Tester} | (tester match: tName) ifTrue: [^tester]]. ^NULL"! {Tester} getTester: tName {char star} "Returns the tester whose name is 'tName'. BLASTs if none." | result {Tester} | result _ self fetchTester: tName. (result == NULL) ifTrue: [Heaper BLAST: #NotFound]. ^result! ! !Tester class methodsFor: 'smalltalk: testing'! {void} auditionFromMenu "Tester auditionFromMenu" "| menuDesc {OrderedCollection of: Array} tName {String} | menuDesc _ OrderedCollection new. Testers stepper forEach: [:tester {Tester} | menuDesc add: (Array with: tester name)]. menuDesc _ menuDesc asSortedCollection: [:a :b | (a at: 1) <= (b at: 1)]. menuDesc _ menuDesc asOrderedCollection. tName _ (PopUpMenu fromArray: menuDesc) startUp. tName = 0 ifTrue: [^VOID]. (Tester getTester: tName) class audition."! {String} defaultRcString ^self name, '(); '! {Behavior} publicClass ^Tester class! {String} runTest ^self runTest: #allTestsOn:! {String} spyTest ^self spyTest: #allTestsOn:! {String} tryTest ^self tryTest: #allTestsOn:! {String} tryTest: test {Symbol} | str {Stream of: char} time {IntegerVar} | str _ WriteStream on: (String new: 200). time _ Time millisecondsToRun: [self create perform: test with: str]. Transcript show: str contents; endEntry. Transcript << 'Run Time = ' ; << time; << ' ms '. " Typically about16 ms is 'self perform:with:' overhead" ^str contents! ! !Tester class methodsFor: 'smalltalk: initialization'! suppressInitTimeInherited! ! !Tester class methodsFor: 'smalltalk: passe'! doLinkTime self passe. "use Initializer doLinkTime"! !Tester subclass: #BecomeTester instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Xpp-Become'! (BecomeTester getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); yourself)! !BecomeTester methodsFor: 'testing'! {void} allTestsOn: oo {ostream reference} "BecomeTester runTest" self test1On: oo.! {void} test1On: oo {ostream reference} "BecomeTester runTest: #test1On:" | cham {Chameleon} | cham _ Moth make. cham explain: oo. (cham cast: Moth) molt. cham explain: oo.! ! !BecomeTester methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !Tester subclass: #DiskTester instanceVariableNames: 'myBootCounter {Counter NOCOPY}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-diskman'! (DiskTester getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); yourself)! !DiskTester methodsFor: 'tests'! {void} destroyTest: oo {ostream reference unused} "self runTest: #destroyTest:" | table {MuTable} | table _ MuTable make: IntegerSpace make. 1 to: 100 do: [:i {Int32} | | shep {Abraham} | table atInt: i introduce: (DoublingFlock make: i with: i). shep _ (table intFetch: i // 2) cast: Abraham. shep ~~ NULL ifTrue: [shep destroy. table intWipe: i // 2]. self unimplemented. "CurrentPacker fluidVar makeConsistent." i \\ 20 == Int32Zero ifTrue: [(CurrentPacker fluidGet cast: SnarfPacker) makePersistent]]. CurrentPacker fluidGet purge! {void} forward1Test: oo {ostream reference} "self runTest: #forward1Test:" | a {DoublingFlock} b {DoublingFlock} packer {SnarfPacker} | a _ DoublingFlock make: 1. b _ DoublingFlock make: 2. packer _ CurrentPacker fluidGet cast: SnarfPacker. oo << 'Flock a is ' << a << ' at ' << a getInfo <<' Flock b is ' << b << ' at ' << b getInfo <<' '. packer makePersistent. [a getInfo snarfID == b getInfo snarfID] whileTrue: [a doDouble. b doDouble. oo << 'doubled to ' << a count << ' '. "a count >= 512 ifTrue: [self halt]." packer makePersistent].! {void} forward2Test: oo {ostream reference} "self runTest: #forward2Test:" | pair {PairFlock} packer {SnarfPacker} | pair _ PairFlock create: (DoublingFlock make: 1) with: (DoublingFlock make: 2). packer _ CurrentPacker fluidGet cast: SnarfPacker. oo << 'Flock a is ' << pair left << ' at ' << pair left getInfo <<' Flock b is ' << pair right << ' at ' << pair right getInfo <<' '. packer makePersistent. [pair left getInfo snarfID == pair right getInfo snarfID] whileTrue: [(pair left cast: DoublingFlock) doDouble. (pair right cast: DoublingFlock) doDouble. oo << 'doubled to ' << (pair left cast: DoublingFlock) count << ' '. "pair left count >= 512 ifTrue: [self halt]." packer purge].! {void} toDiskAndBackTestOn: aStream {ostream reference} "self runTest: #toDiskAndBackTestOn:" "test writing to disk and reading back" | firstCounter {MultiCounter} secondCounter {MultiCounter} | aStream << ' Test ability to write an object to disk and read it back '. firstCounter _ MultiCounter make: 5. firstCounter incrementBoth. secondCounter _ MultiCounter make. secondCounter incrementFirst; incrementFirst; incrementBoth. aStream << ' First MultiCounter = ' << firstCounter. aStream << ' Second MultiCounter = ' << secondCounter. aStream << ' Purging.'. CurrentPacker fluidGet purge. aStream << ' Bringing First MultiCounter back; value = ' << firstCounter. firstCounter decrementBoth; decrementSecond. aStream << ' First MultiCounter = ' << firstCounter. aStream << ' Bringing Second MultiCounter back and incrementing.'. secondCounter incrementSecond; incrementSecond; incrementBoth. aStream << ' Second MultiCounter = ' << secondCounter. aStream << ' Purging again.'. CurrentPacker fluidGet purge. aStream << ' Bringing First MultiCounter back; value = ' << firstCounter. firstCounter decrementBoth; decrementSecond. aStream << ' First MultiCounter = ' << firstCounter. aStream << ' Bringing Second MultiCounter back and incrementing.'. secondCounter incrementSecond; incrementSecond; incrementBoth. aStream << ' Second MultiCounter = ' << secondCounter.! ! !DiskTester methodsFor: 'running tests'! {void} allTestsOn: oo {ostream reference} "DiskTester runTest" | conn {Connection} | conn _ Connection make: Counter. myBootCounter _ conn bootHeaper cast: Counter. self destroyTest: oo. self toDiskAndBackTestOn: oo. self forward1Test: oo. self forward2Test: oo. conn destroy! ! !DiskTester methodsFor: 'hooks:'! {void RECEIVE.HOOK} restartDiskTester: rcvr {Rcvr unused default: NULL} myBootCounter _ NULL! ! !DiskTester methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. self restartDiskTester: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !Tester subclass: #GrandHashTableTester instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Grand'! (GrandHashTableTester getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); yourself)! !GrandHashTableTester methodsFor: 'tests'! {void} bigTableTestOn: aStream {ostream reference} "self runTest: #bigTableTestOn:" "test growing" | tab {MuTable of: Pair} keys {MuSet of: HeaperAsPosition} | aStream << 'Test growth behavior of GrandHashTable '. tab _ GrandHashTable make: HeaperSpace make. keys _ MuSet make: 4000. 1 to: 4000 do: [ :i {Int32} | | thing {Pair} key {HeaperAsPosition} | thing _ Pair make: (IntegerPos make: 4000) with: (IntegerPos make: 3 * i). key _ HeaperAsPosition make: thing. tab at: key introduce: thing. keys introduce: key. "i > 400 ifTrue: [keys stepper forEach: [ : foo {HeaperAsPosition} | tab get: foo]]"]. keys stepper forEach: [ :key {HeaperAsPosition} | tab get: key]. aStream << 'Growth test successful. '.! {void} test1On: oo {ostream reference} "self runTest: #test1On:" "test creation" | tab1 {MuTable} tab2 {MuTable} | oo << 'Create tables with create, create: and create:with: '. tab1 _ GrandHashTable make: IntegerSpace make. tab2 _ GrandHashTable make: IntegerSpace make with: 4. "test printing" oo << 'Printing tables: ' << tab1 << ' ' << tab2 << ' '. "testing empty" oo << 'Test empty table: '. tab1 isEmpty ifTrue: [oo << 'Empty'] ifFalse: [oo << 'Not Empty']. oo << ' '. "inserting" tab1 atInt: 1 introduce: (UInt8Array string: 'filly'). tab1 atInt: IntegerVar0 introduce: (UInt8Array string: 'mare'). oo << 'Test introduce: ' << tab1 << ', table count now: ' << tab1 count << ' '. tab1 atInt: -1 introduce: (UInt8Array string: 'colt'). oo << 'Test introduce: ' << tab1 << ', table count now: ' << tab1 count << ' '. tab1 atInt: 27 introduce: (UInt8Array string: 'stallion'). oo << 'Test introduce: ' << tab1 << ', table count now: ' << tab1 count << ' '. MuTable problems.AlreadyInTable handle: [:ex | oo << 'already in table blast caught, table now: ' << tab1 << ' and table count: ' << tab1 count << ' '. ^VOID] do: [tab1 atInt: 1 introduce: (UInt8Array string: 'palooka')]. oo << 'Test empty table: '. tab1 isEmpty ifTrue: [oo << 'Empty'] ifFalse: [oo << 'Not Empty']. oo << ' '.! {void} test2On: aStream {ostream reference} "self runTest: #test2On:" "test creation" | tab1 {MuTable} | aStream << 'Create tables. '. tab1 _ GrandHashTable make: IntegerSpace make. tab1 atInt: 1 introduce: (UInt8Array string: 'filly'). tab1 atInt: IntegerVar0 introduce: (UInt8Array string: 'mare'). tab1 atInt: -1 introduce: (UInt8Array string: 'colt'). tab1 atInt: 27 introduce: (UInt8Array string: 'stallion'). aStream << 'Starting table is: ' << tab1 << ' '. tab1 atInt: 1 replace: (UInt8Array string: 'mare'). aStream << 'after replace: ' << tab1 << ' and table count: ' << tab1 count << ' '. aStream << 'Test replace() in unknown territory. '. ScruTable problems.NotInTable handle: [:ex | aStream << 'NotInTable blast caught, table now: ' << tab1 << ' and table count: ' << tab1 count << ' '. ^VOID] do: [tab1 atInt: 2 replace: (UInt8Array string: 'palooka')]. aStream << 'Test replace() with NULL. '. MuTable problems.NullInsertion handle: [:ex | aStream << 'NullInsertion blast caught, table now: ' << tab1 << ' and table count: ' << tab1 count << ' '. ^VOID] do: [tab1 atInt: 1 replace: NULL. aStream << 'Replace(NULL) not caught!! ']! {void} test3On: aStream {ostream reference} "self runTest: #test3On:" "test creation" | tab1 {MuTable} | aStream << 'Create tables. '. tab1 _ GrandHashTable make: IntegerSpace make. tab1 atInt: 1 introduce: (UInt8Array string: 'filly'). tab1 atInt: IntegerVar0 introduce: (UInt8Array string: 'mare'). tab1 atInt: -1 introduce: (UInt8Array string: 'colt'). tab1 atInt: 27 introduce: (UInt8Array string: 'stallion'). aStream << 'Starting table is: ' << tab1 << ' '. tab1 atInt: 1 store: (UInt8Array string: 'mare'). aStream << 'after store: ' << tab1 << ' and table count: ' << tab1 count << ' '. aStream << 'Test store() in unknown territory. '. ScruTable problems.NotInTable handle: [:ex | aStream << 'NotInTable blast caught, table now: ' << tab1 << ' and table count: ' << tab1 count << ' '. ^VOID] do: [tab1 atInt: 2 store: (UInt8Array string: 'palooka')]. aStream << 'after store: ' << tab1 << ' and table count: ' << tab1 count << ' '. aStream << 'Test store() with NULL. '. MuTable problems.NullInsertion handle: [:ex | aStream << 'NullInsertion blast caught, table now: ' << tab1 << ' and table count: ' << tab1 count << ' '. ^VOID] do: [tab1 atInt: 3 store: NULL]! {void} test4On: aStream {ostream reference} "self runTest: #test4On:" "test creation" | tab1 {MuTable} | aStream << 'Create tables. '. tab1 _ GrandHashTable make: IntegerSpace make. tab1 at: 1 integer introduce: (UInt8Array string: 'filly'). tab1 at: Integer0 introduce: (UInt8Array string: 'mare'). tab1 at: -1 integer introduce: (UInt8Array string: 'colt'). tab1 at: 27 integer introduce: (UInt8Array string: 'stallion'). aStream << 'Starting table is: ' << tab1 << ' with count ' << tab1 count << ' '. "testing enclosure" aStream << 'Testing domain ' << tab1 domain << ' '. "test get" aStream << 'Test get(1) ' << (tab1 intGet: 1) << ' '. aStream << 'Test get() in unknown territory. '. ScruTable problems.NotInTable handle: [:ex | aStream << 'NotInTable blast caught, table now: ' << tab1 << ' and table count: ' << tab1 count << ' '. ^VOID] do: [tab1 intGet: 14]! {void} test5On: aStream {ostream reference} "self runTest: #test5On:" "test creation" | tab1 {MuTable} | aStream << 'Create tables. '. tab1 _ GrandHashTable make: IntegerSpace make. tab1 atInt: 1 introduce: (UInt8Array string: 'filly'). tab1 atInt: IntegerVar0 introduce: (UInt8Array string: 'mare'). tab1 atInt: -1 introduce: (UInt8Array string: 'colt'). tab1 atInt: 27 introduce: (UInt8Array string: 'stallion'). aStream << 'Starting table is: ' << tab1 << ' with count ' << tab1 count << ' Now, testing remove(1) '. tab1 intRemove: 1. aStream << 'Table now: ' << tab1 << ' with count ' << tab1 count << ' '. aStream << 'Test remove(1) in unknown territory. '. ScruTable problems.NotInTable handle: [:ex | aStream << 'NotInTable blast caught, table now: ' << tab1 << ' and table count: ' << tab1 count << ' '. ^VOID] do: [tab1 intRemove: 1]. aStream << 'Test wipe(0) '. tab1 wipe: Integer0. aStream << 'Table now: ' << tab1 << ' with count ' << tab1 count << ' And wipe(0) again: '. tab1 wipe: Integer0. aStream << 'Table now: ' << tab1 << ' with count ' << tab1 count << ' '! {void} test7On: aStream {ostream reference} "self runTest: #test7On:" "Not currently appropriate to GrandHashTable" "runs {Iterator}" "test creation" | tab1 {MuTable} | aStream << 'Create tables. '. tab1 _ GrandHashTable make: IntegerSpace make. tab1 atInt: 1 introduce: (UInt8Array string: 'filly'). tab1 atInt: IntegerVar0 introduce: (UInt8Array string: 'mare'). tab1 atInt: -1 introduce: (UInt8Array string: 'colt'). tab1 atInt: 27 introduce: (UInt8Array string: 'stallion'). aStream << 'Starting table is: ' << tab1 << ' with count ' << tab1 count << ' Now, testing runEnclosures '. " runs _ tab1 domain. aStream << 'And the results (ta ta TUM!!) ' << runs << ' and now, run lengths.... '." aStream << 'tab1 runAt: -20 ->' << (tab1 runAtInt: -20). aStream << ' tab1 runLengthAt: -10 ->' << (tab1 runAtInt: -10). aStream << ' tab1 runLengthAt: -9 ->' << (tab1 runAtInt: -9). -1 to: 4 do: [:i {IntegerVar} | aStream << ' tab1 runLengthAt: ' << i << ' ->' << (tab1 runAtInt: i)]. aStream << ' tab1 runLengthAt: 26 ->' << (tab1 runAtInt: 26). aStream << ' tab1 runLengthAt: 27 ->' << (tab1 runAtInt: 27). aStream << ' tab1 runLengthAt: 28 ->' << (tab1 runAtInt: 28). aStream << ' tab1 runLengthAt: 30 ->' << (tab1 runAtInt: 30). aStream << ' tab1 runAt.IntegerVar: 31 ->' << (tab1 runAtInt: 31). aStream << ' tab1 runAt.IntegerVar: 32 ->' << (tab1 runAtInt: 32)! ! !GrandHashTableTester methodsFor: 'running tests'! {void} allTestsOn: aStream {ostream reference} aStream << 'Running all HashTable tests. Test 1 '. self test1On: aStream. aStream << ' Test 2 '. self test2On: aStream. aStream << ' Test 3 '. self test3On: aStream. aStream << ' Test 4 '. self test4On: aStream. aStream << ' Test 5 '. self test5On: aStream. self bigTableTestOn: aStream.! ! !GrandHashTableTester methodsFor: 'smalltalk: smalltalk tests'! runTest: test | str | str _ WriteStream on: (String new: 200). self perform: test with: str. Transcript show: str contents; endEntry! {GrandHashTable} stomp: anInt {UInt32} | table rGen rNum | table _ GrandHashTable make: anInt. rGen _ Random new. 0 to: 1000 do: [:i | rNum _ rGen next * 32768. (table includesKey: rNum) ifTrue: [table at: rNum replace: i] ifFalse: [table at: rNum introduce: i]]. ^table! {GrandHashTable} stomp: anInt {UInt32} with: anotherInt {UInt32} |table rGen rNum| table _ GrandHashTable make: anInt. rGen _ Random new. 0 to: (anotherInt - 1) do: [:i | rNum _ ((rGen next) * 32768) asInteger. (table includesIntKey: rNum) ifTrue: [table atInt: rNum replace: i] ifFalse: [table atInt: rNum introduce: i]]. ^ table! ! !GrandHashTableTester methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !Tester subclass: #HashTableTester instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Testing'! (HashTableTester getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); yourself)! !HashTableTester methodsFor: 'tests'! {void} test1On: oo {ostream reference} "self runTest: #test1On:" "test creation" | tab1 {MuTable} tab2 {MuTable} | oo << 'Create tables with create, create: and create:with: '. tab1 _ HashTable make.CoordinateSpace: IntegerSpace make. tab2 _ HashTable make.CoordinateSpace: IntegerSpace make with: 4. "test printing" oo << 'Printing tables: ' << tab1 << ' ' << tab2 << ' '. "testing empty" oo << 'Test empty table: '. tab1 isEmpty ifTrue: [oo << 'Empty'] ifFalse: [oo << 'Not Empty']. oo << ' '. "inserting" tab1 atInt: 1 introduce: (Sequence string: 'filly'). tab1 atInt: IntegerVar0 introduce: (Sequence string: 'mare'). oo << 'Test introduce: ' << tab1 << ', table count now: ' << tab1 count << ' '. tab1 at: (Sequence string: 'mare') introduce: (Sequence string: 'colt'). oo << 'Test introduce: ' << tab1 << ', table count now: ' << tab1 count << ' '. tab1 atInt: 27 introduce: (Sequence string: 'stallion'). oo << 'Test introduce: ' << tab1 << ', table count now: ' << tab1 count << ' '. MuTable problems.AlreadyInTable handle: [:ex | oo << 'already in table blast caught, table now: ' << tab1 << ' and table count: ' << tab1 count << ' '. ^VOID] do: [tab1 atInt: 1 introduce: (Sequence string: 'palooka')]. oo << 'Test empty table: '. tab1 isEmpty ifTrue: [oo << 'Empty'] ifFalse: [oo << 'Not Empty']. oo << ' '! {void} test2On: aStream {ostream reference} "self runTest: #test2On:" "test creation" | tab1 {MuTable} | aStream << 'Create tables. '. tab1 _ HashTable make.CoordinateSpace: IntegerSpace make. tab1 atInt: 1 introduce: (Sequence string: 'filly'). tab1 atInt: IntegerVar0 introduce: (Sequence string: 'mare'). tab1 atInt: -1 introduce: (Sequence string: 'colt'). tab1 atInt: 27 introduce: (Sequence string: 'stallion'). aStream << 'Starting table is: ' << tab1 << ' '. tab1 atInt: 1 replace: (Sequence string: 'mare'). aStream << 'after replace: ' << tab1 << ' and table count: ' << tab1 count << ' '. aStream << 'Test replace() in unknown territory. '. ScruTable problems.NotInTable handle: [:ex | aStream << 'NotInTable blast caught, table now: ' << tab1 << ' and table count: ' << tab1 count << ' '. ^VOID] do: [tab1 atInt: 2 replace: (Sequence string: 'palooka')]. aStream << 'Test replace() with NULL. '. MuTable problems.NullInsertion handle: [:x | aStream << 'NullInsertion blast caught, table now: ' << tab1 << ' and table count: ' << tab1 count << ' '. ^VOID] do: [tab1 atInt: 1 replace: NULL. aStream << 'Replace(NULL) not caught!! ']! {void} test3On: aStream {ostream reference} "self runTest: #test3On:" "test creation" | tab1 {MuTable} | aStream << 'Create tables. '. tab1 _ HashTable make.CoordinateSpace: IntegerSpace make. tab1 atInt: 1 introduce: (Sequence string: 'filly'). tab1 atInt: IntegerVar0 introduce: (Sequence string: 'mare'). tab1 atInt: -1 introduce: (Sequence string: 'colt'). tab1 atInt: 27 introduce: (Sequence string: 'stallion'). aStream << 'Starting table is: ' << tab1 << ' '. tab1 atInt: 1 store: (Sequence string: 'mare'). aStream << 'after store: ' << tab1 << ' and table count: ' << tab1 count << ' '. aStream << 'Test store() in unknown territory. '. ScruTable problems.NotInTable handle: [:ex | aStream << 'NotInTable blast caught, table now: ' << tab1 << ' and table count: ' << tab1 count << ' '. ^VOID] do: [tab1 atInt: 2 store: (Sequence string: 'palooka')]. aStream << 'after store: ' << tab1 << ' and table count: ' << tab1 count << ' '. aStream << 'Test store() with NULL. '. MuTable problems.NullInsertion handle: [:exc | aStream << 'NullInsertion blast caught, table now: ' << tab1 << ' and table count: ' << tab1 count << ' '. ^VOID] do: [tab1 atInt: 3 store: NULL]! {void} test4On: aStream {ostream reference} "self runTest: #test4On:" "test creation" | tab1 {MuTable} | aStream << 'Create tables. '. tab1 _ HashTable make.CoordinateSpace: IntegerSpace make. tab1 at: 1 integer introduce: (Sequence string: 'filly'). tab1 at: Integer0 introduce: (Sequence string: 'mare'). tab1 at: -1 integer introduce: (Sequence string: 'colt'). tab1 at: 27 integer introduce: (Sequence string: 'stallion'). aStream << 'Starting table is: ' << tab1 << ' with count ' << tab1 count << ' '. "testing domain" aStream << 'Testing domain ' << tab1 domain << ' '. "test get" aStream << 'Test get(1) ' << (tab1 intGet: 1) << ' '. aStream << 'Test get() in unknown territory. '. ScruTable problems.NotInTable handle: [:ex | aStream << 'NotInTable blast caught, table now: ' << tab1 << ' and table count: ' << tab1 count << ' '. ^VOID] do: [tab1 intGet: 14]! {void} test5On: aStream {ostream reference} "self runTest: #test5On:" "test creation" | tab1 {MuTable} | aStream << 'Create tables. '. tab1 _ HashTable make.CoordinateSpace: IntegerSpace make. tab1 atInt: 1 introduce: (Sequence string: 'filly'). tab1 atInt: IntegerVar0 introduce: (Sequence string: 'mare'). tab1 atInt: -1 introduce: (Sequence string: 'colt'). tab1 atInt: 27 introduce: (Sequence string: 'stallion'). aStream << 'Starting table is: ' << tab1 << ' with count ' << tab1 count << ' Now, testing remove(1) '. tab1 intRemove: 1. aStream << 'Table now: ' << tab1 << ' with count ' << tab1 count << ' '. aStream << 'Test remove(1) in unknown territory. '. ScruTable problems.NotInTable handle: [:ex | aStream << 'NotInTable blast caught, table now: ' << tab1 << ' and table count: ' << tab1 count << ' '. ^VOID] do: [tab1 intRemove: 1]. aStream << 'Test wipe(0) '. tab1 wipe: Integer0. aStream << 'Table now: ' << tab1 << ' with count ' << tab1 count << ' And wipe(0) again: '. tab1 wipe: Integer0. aStream << 'Table now: ' << tab1 << ' with count ' << tab1 count << ' '! {void} test6On: aStream {ostream reference} "self runTest: #test6On:" "test creation" | tab1 {MuTable} | aStream << 'Create tables. '. tab1 _ HashTable make.CoordinateSpace: IntegerSpace make. tab1 atInt: 1 introduce: (Sequence string: 'filly'). tab1 atInt: IntegerVar0 introduce: (Sequence string: 'mare'). tab1 atInt: -1 introduce: (Sequence string: 'colt'). tab1 atInt: 27 introduce: (Sequence string: 'stallion'). " tab2 _ tab1 subTable: 0 integer with: 40. aStream << 'Table now: ' << tab1 << ' with count ' << tab1 count << ' and the subtable is ' << tab2 << ' and its count is ' << tab2 count << '. '." aStream << 'Starting table is: ' << tab1 << ' with count ' << tab1 count << ' Now, testing subTable(0,40) '! {void} test7On: aStream {ostream reference} "self runTest: #test7On:" "runs {Iterator}" "test creation" | tab1 {MuTable} domain {XnRegion} | aStream << 'Create tables. '. tab1 _ HashTable make.CoordinateSpace: IntegerSpace make. tab1 atInt: 1 introduce: (UInt8Array string: 'filly'). tab1 atInt: IntegerVar0 introduce: (UInt8Array string: 'mare'). tab1 atInt: -1 introduce: (UInt8Array string: 'colt'). tab1 atInt: 27 introduce: (UInt8Array string: 'stallion'). aStream << 'Starting table is: ' << tab1 << ' with count ' << tab1 count << ' Now, testing domain '. domain _ tab1 domain. aStream << 'And the results (ta ta TUM!!) ' << domain << ' '.! {void} testStepperCopyOn: aStream {ostream reference} "self runTest: #testStepperCopyOn:" | tab1 {MuTable} tab2 {MuTable} stp {TableStepper} | aStream << 'Test copy by stepper. '. tab1 _ HashTable make.CoordinateSpace: IntegerSpace make. tab1 atInt: 1 introduce: (UInt8Array string: 'filly'). tab1 atInt: IntegerVar0 introduce: (UInt8Array string: 'mare'). tab1 atInt: -1 introduce: (UInt8Array string: 'colt'). tab1 atInt: 27 introduce: (UInt8Array string: 'stallion'). aStream << 'Starting table is: ' << tab1 << ' with count ' << tab1 count << '. Now testing store during forEach loop '. (stp _ tab1 stepper) forEach: [ :e {Heaper} | aStream << 'at index ' << stp position << ' storing ' << stp position << ' on top of ' << e << ' '. tab1 at: stp position store: stp position]. aStream << 'Ending table is: ' << tab1 << ' with count ' << tab1 count << '. '. tab2 _ tab1 copy cast: MuTable. (stp _ tab2 stepper) forEach: [ :x {Heaper} | aStream << 'at index ' << stp position << ' storing ''foo'' on top of ' << x << ' '. tab2 at: stp position store: (UInt8Array string: 'foo')]. aStream << 'Ending table is: ' << tab2 << ' with count ' << tab2 count << '. Done with stepperCopy test. '.! ! !HashTableTester methodsFor: 'running tests'! {void} allTestsOn: aStream {ostream reference} "self runTest: #allTestsOn:" aStream << 'Running all HashTable tests. Test 1 '. self test1On: aStream. aStream << ' Test 2 '. self test2On: aStream. aStream << ' Test 3 '. self test3On: aStream. aStream << ' Test 4 '. self test4On: aStream. aStream << ' Test 5 '. self test5On: aStream. aStream << ' Test 6 '. self test6On: aStream. aStream << ' Test 7 '. self test7On: aStream. self testStepperCopyOn: aStream.! ! !HashTableTester methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !Tester subclass: #HelloTester instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Testing'! (HelloTester getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); yourself)! !HelloTester methodsFor: 'testing'! {IntegerVar ifdefFOO ifndefBAR} ifdefTest ^IntegerVar0! {void} test1On: aStream {ostream reference} "self tryTest: #test1On:" aStream << 'Hello, translated world!! '! ! !HelloTester methodsFor: 'running tests'! {void} allTestsOn: aStream {ostream reference} "HelloTester runTest" aStream << ' Running Hello, world!! test. '. self test1On: aStream.! ! !HelloTester methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !Tester subclass: #IntegerTableTester instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Testing'! (IntegerTableTester getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); yourself)! !IntegerTableTester methodsFor: 'testing'! {void} cleanTable: aTable {ScruTable} | stomp {TableStepper} | stomp _ aTable stepper. [stomp hasValue] whileTrue: [stomp fetch destroy. stomp step]. aTable destroy! {void} test1On: oo {ostream reference} "IntegerTableTester runTest: #test1On:" "test creation" | tab1 {MuTable} tab2 {MuTable} tab3 {MuTable} | oo << 'Create tables with create, create: and create:with: '. tab1 _ IntegerTable make. tab2 _ IntegerTable make.IntegerVar: 4. tab3 _ IntegerTable make.IntegerVar: 5 with: 9. "test printing" oo << 'Printing tables: ' << tab1 << ' ' << tab2 << ' ' << tab3 << ' '. "testing" oo << 'Test empty table: '. tab2 isEmpty ifTrue: [oo << 'Empty'] ifFalse: [oo << 'Not Empty']. oo << ' '. "inserting" tab1 at: (9 integer) introduce: (Sequence string: 'filly'). tab1 atInt: IntegerVar0 introduce: (Sequence string: 'mare'). oo << 'Test introduce: ' << tab1 << ', table count now: ' << tab1 count << ' '. tab1 atInt: -11 introduce: (Sequence string: 'colt'). oo << 'Test introduce: ' << tab1 << ', table count now: ' << tab1 count << ' '. tab1 atInt: 47 introduce: (Sequence string: 'stallion'). oo << 'Test introduce: ' << tab1 << ', table count now: ' << tab1 count << ' '. MuTable problems.AlreadyInTable handle: [:ex | oo << 'already in table blast caught, table now: ' << tab1 << ' and table count: ' << tab1 count << ' '. ^VOID] do: [tab1 atInt: 1 introduce: (Sequence string: 'palooka')]. oo << 'Test introduce: '. oo << 'Testing introduce and fetch boundary conditions '. 5 to: 9 do: [:i {IntegerVar} | tab3 atInt: i introduce: i integer. oo << 'fetch of (' << i << ') is ' << (tab3 intFetch: i) << ' ']. oo << 'table 3 now: ' << tab3 << ' and its count is ' << tab3 count << ' '. tab3 atInt: 4 introduce: 4 integer. tab3 atInt: 10 introduce: 10 integer. tab3 atInt: 11 introduce: 11 integer. oo << 'table 3 now: ' << tab3 << ' and its count is ' << tab3 count << ' '. self cleanTable: tab1. self cleanTable: tab2. self cleanTable: tab3! {void} test2On: aStream {ostream reference} "self runTest: #test2On:" "test creation" | tab1 {MuTable} | aStream << 'Create tables. '. tab1 _ IntegerTable make. tab1 atInt: 1 introduce: (Sequence string: 'filly'). tab1 atInt: IntegerVar0 introduce: (Sequence string: 'mare'). tab1 atInt: -1 introduce: (Sequence string: 'colt'). tab1 atInt: 27 introduce: (Sequence string: 'stallion'). aStream << 'Starting table is: ' << tab1 << ' '. tab1 atInt: 1 replace: (Sequence string: 'mare'). aStream << 'after replace: ' << tab1 << ' and table count: ' << tab1 count << ' '. aStream << 'Test replace() in unknown territory. '. (ScruTable problems.NotInTable) handle: [:ex | aStream << 'NotInTable blast caught, table now: ' << tab1 << ' and table count: ' << tab1 count << ' '. ^VOID] do: [tab1 atInt: 2 replace: (Sequence string: 'palooka')]. aStream << 'Test replace() with NULL. '. (MuTable problems.NullInsertion) handle: [:exc | aStream << 'NullInsertion blast caught, table now: ' << tab1 << ' and table count: ' << tab1 count << ' '. ^VOID] do: [tab1 atInt: 1 replace: NULL. aStream << 'Replace(NULL) not caught!! ']. self cleanTable: tab1! {void} test3On: aStream {ostream reference} "self runTest: #test3On:" "test creation" | tab1 {MuTable} | aStream << 'Create tables. '. tab1 _ IntegerTable make. tab1 atInt: 1 introduce: (Sequence string: 'filly'). tab1 atInt: IntegerVar0 introduce: (Sequence string: 'mare'). tab1 atInt: -1 introduce: (Sequence string: 'colt'). tab1 atInt: 27 introduce: (Sequence string: 'stallion'). aStream << 'Starting table is: ' << tab1 << ' '. tab1 atInt: 1 store: (Sequence string: 'mare'). aStream << 'after store: ' << tab1 << ' and table count: ' << tab1 count << ' '. aStream << 'Test store() in unknown territory. '. (ScruTable problems.NotInTable) handle: [:ex | aStream << 'NotInTable blast caught, table now: ' << tab1 << ' and table count: ' << tab1 count << ' '. ^VOID] do: [tab1 atInt: 2 store: (Sequence string: 'palooka')]. aStream << 'after store: ' << tab1 << ' and table count: ' << tab1 count << ' '. aStream << 'Test store() with NULL. '. (MuTable problems.NullInsertion) handle: [:exc | aStream << 'NullInsertion blast caught, table now: ' << tab1 << ' and table count: ' << tab1 count << ' '. ^VOID] do: [tab1 atInt: 3 store: NULL]. self cleanTable: tab1! {void} test4On: aStream {ostream reference} "self runTest: #test4On:" "test creation" | tab1 {MuTable} | aStream << 'Create tables. '. tab1 _ IntegerTable make. tab1 atInt: 1 introduce: (Sequence string: 'filly'). tab1 atInt: IntegerVar0 introduce: (Sequence string: 'mare'). tab1 atInt: -1 introduce: (Sequence string: 'colt'). tab1 atInt: 27 introduce: (Sequence string: 'stallion'). aStream << 'Starting table is: ' << tab1 << ' with count ' << tab1 count << ' '. "testing domain" aStream << 'Testing domain ' << tab1 domain << ' '. "test get" aStream << 'Test get(1) ' << (tab1 intGet: 1) << ' '. aStream << 'Test get() in unknown territory. '. (ScruTable problems.NotInTable) handle: [:ex | aStream << 'NotInTable blast caught, table now: ' << tab1 << ' and table count: ' << tab1 count << ' '. ^VOID] do: [tab1 intGet:14]. self cleanTable: tab1! {void} test5On: aStream {ostream reference} "self runTest: #test5On:" "test creation" | tab1 {MuTable} | aStream << 'Create tables. '. tab1 _ IntegerTable make. tab1 atInt: 1 introduce: (Sequence string: 'filly'). tab1 atInt: IntegerVar0 introduce: (Sequence string: 'mare'). tab1 atInt: -1 introduce: (Sequence string: 'colt'). tab1 atInt: 27 introduce: (Sequence string: 'stallion'). aStream << 'Starting table is: ' << tab1 << ' with count ' << tab1 count << ' Now, testing remove(1) '. tab1 intRemove: 1. aStream << 'Table now: ' << tab1 << ' with count ' << tab1 count << ' '. aStream << 'Test remove(1) in unknown territory. '. ScruTable problems.NotInTable handle: [:ex | aStream << 'NotInTable blast caught, table now: ' << tab1 << ' and table count: ' << tab1 count << ' '. ^VOID] do: [tab1 intRemove: 1]. aStream << 'Test wipe(0) '. tab1 intWipe: IntegerVar0. aStream << 'Table now: ' << tab1 << ' with count ' << tab1 count << ' And wipe(0) again: '. tab1 intWipe: IntegerVar0. aStream << 'Table now: ' << tab1 << ' with count ' << tab1 count << ' '. self cleanTable: tab1! {void} test6On: aStream {ostream reference} "self runTest: #test6On:" "test creation" | tab1 {MuTable} tab2 {ScruTable} | aStream << 'Create tables. '. tab1 _ IntegerTable make. tab1 atInt: 1 introduce: (Sequence string: 'filly'). tab1 atInt: IntegerVar0 introduce: (Sequence string: 'mare'). tab1 atInt: -1 introduce: (Sequence string: 'colt'). tab1 atInt: 27 introduce: (Sequence string: 'stallion'). aStream << 'Starting table is: ' << tab1 << ' with count ' << tab1 count << ' Now, testing subTable(0,40) '. tab2 _ (tab1 cast: IntegerTable) subTable: (IntegerRegion make: IntegerVar0 with: 40). aStream << 'Table now: ' << tab1 << ' with count ' << tab1 count << ' and the subtable is ' << tab2 << ' and its count is ' << tab2 count << '. '. self cleanTable: tab1! {void} test7On: aStream {ostream reference} "self runTest: #test7On:" "runs {Iterator}" "test creation" | tab1 {MuTable} dom {XnRegion} | aStream << 'Create tables. '. tab1 _ IntegerTable make. tab1 atInt: 1 introduce: (Sequence string: 'filly'). tab1 atInt: IntegerVar0 introduce: (Sequence string: 'mare'). tab1 atInt: -1 introduce: (Sequence string: 'colt'). tab1 atInt: 27 introduce: (Sequence string: 'stallion'). aStream << 'Starting table is: ' << tab1 << ' with count ' << tab1 count << ' Now, testing domain '. dom _ tab1 domain. aStream << 'And the results (ta ta TUM!!) ' << dom << ' '. aStream << ' and now, run lengths.... '. aStream << 'tab1 runAt.IntegerVar: -20 ->' << (tab1 runAtInt: -20). aStream << ' tab1 runAt.IntegerVar: -10 ->' << (tab1 runAtInt: -10). aStream << ' tab1 runAt.IntegerVar: -9 ->' << (tab1 runAtInt: -9). -1 to: 4 do: [:i {IntegerVar} | aStream << ' tab1 runAt.IntegerVar: ' << i << ' ->' << (tab1 runAtInt: i)]. aStream << ' tab1 runAt.IntegerVar: 26 ->' << (tab1 runAtInt: 26). aStream << ' tab1 runAt.IntegerVar: 27 ->' << (tab1 runAtInt: 27). aStream << ' tab1 runAt.IntegerVar: 28 ->' << (tab1 runAtInt: 28). aStream << ' tab1 runAt.IntegerVar: 30 ->' << (tab1 runAtInt: 30). aStream << ' tab1 runAt.IntegerVar: 31 ->' << (tab1 runAtInt: 31). aStream << ' tab1 runAt.IntegerVar: 32 ->' << (tab1 runAtInt: 32). aStream << ' '. self cleanTable: tab1! ! !IntegerTableTester methodsFor: 'running tests'! {void} allTestsOn: aStream {ostream reference} "IntegerTableTester runTest" aStream << 'Running all IntegerTable tests. Test 1 '. self test1On: aStream. aStream << ' Test 2 '. self test2On: aStream. aStream << ' Test 3 '. self test3On: aStream. aStream << ' Test 4 '. self test4On: aStream. aStream << ' Test 5 '. self test5On: aStream. aStream << ' Test 6 '. self test6On: aStream. aStream << ' Test 7 '. self test7On: aStream! ! !IntegerTableTester methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !Tester subclass: #LogTester instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-hlogger'! (LogTester getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); yourself)! !LogTester methodsFor: 'testing'! {void} allTestsOn: oo {ostream reference} FooLog << 'foo ' << self << ' '. VanillaLog << 'bar ' << self << ' '. ErrorLog << 'err ' << self << ' '. FooLog LOG: [:ooo | ooo << 'zip ' << self << ' ']. VanillaLog LOG: [:ooo | ooo << 'zap ' << self << ' ']. ErrorLog LOG: [:ooo | ooo << 'human ' << self << ' '].! ! !LogTester methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! LogTester class instanceVariableNames: ''! (LogTester getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); yourself)! !LogTester class methodsFor: 'smalltalk: init'! linkTimeNonInherited Logger defineLogger: #FooLog! !Tester subclass: #PrimIndexTableTester instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-primtab'! (PrimIndexTableTester getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); yourself)! !PrimIndexTableTester methodsFor: 'tests'! {void} accessTestOn: oo {ostream reference} | tab {PrimIndexTable} | "For this tests, I use as keys category pointers from the minimal xpp set" tab := PrimIndexTable make: 7. "first test a few introduces" tab at: Heaper introduce: 1. tab at: Category introduce: 2. tab at: PrimIndexTable introduce: 3. (tab get: Heaper) ~~ 1 ifTrue: [ Heaper BLAST: #IntroduceFailed ]. (tab get: Category) ~~ 2 ifTrue: [ Heaper BLAST: #IntroduceFailed ]. (tab get: PrimIndexTable) ~~ 3 ifTrue: [ Heaper BLAST: #IntroduceFailed ]. "now do some more to cause a grow." tab at: Tester introduce: 4. tab at: PrimIndexTableTester introduce: 5. tab at: Recipe introduce: 7. tab at: BootMaker introduce: 8. (tab get: Heaper) ~~ 1 ifTrue: [ Heaper BLAST: #IntroduceFailed ]. (tab get: Category) ~~ 2 ifTrue: [ Heaper BLAST: #IntroduceFailed ]. (tab get: PrimIndexTable) ~~ 3 ifTrue: [ Heaper BLAST: #IntroduceFailed ]. (tab get: Tester) ~~ 4 ifTrue: [ Heaper BLAST: #IntroduceFailed ]. (tab get: PrimIndexTableTester) ~~ 5 ifTrue: [ Heaper BLAST: #IntroduceFailed ]. (tab get: Recipe) ~~ 7 ifTrue: [ Heaper BLAST: #IntroduceFailed ]. (tab get: BootMaker) ~~ 8 ifTrue: [ Heaper BLAST: #IntroduceFailed ]. "Now remove some stuff." tab remove: Recipe. (tab get: Heaper) ~~ 1 ifTrue: [ Heaper BLAST: #RemoveFouled ]. (tab get: Category) ~~ 2 ifTrue: [ Heaper BLAST: #RemoveFouled ]. (tab get: PrimIndexTable) ~~ 3 ifTrue: [ Heaper BLAST: #RemoveFouled ]. (tab get: Tester) ~~ 4 ifTrue: [ Heaper BLAST: #IntroduceFailed ]. (tab get: PrimIndexTableTester) ~~ 5 ifTrue: [ Heaper BLAST: #IntroduceFailed ]. (tab get: BootMaker) ~~ 8 ifTrue: [ Heaper BLAST: #IntroduceFailed ].! ! !PrimIndexTableTester methodsFor: 'testing'! {void} allTestsOn: oo {ostream reference} self accessTestOn: oo! ! !PrimIndexTableTester methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !Tester subclass: #PrimPtrTableTester instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-primtab'! (PrimPtrTableTester getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); yourself)! !PrimPtrTableTester methodsFor: 'tests'! {void} accessTestOn: oo {ostream reference} | tab {PrimPtrTable} | "For this tests, I use as keys category pointers from the minimal xpp set" tab := PrimPtrTable make: 7. "first test a few introduces" tab at: 1 introduce: Heaper. tab at: 2 introduce: Category. tab at: 3 introduce: PrimIndexTable. (tab get: 1) ~~ Heaper ifTrue: [ Heaper BLAST: #IntroduceFailed ]. (tab get: 2) ~~ Category ifTrue: [ Heaper BLAST: #IntroduceFailed ]. (tab get: 3) ~~ PrimIndexTable ifTrue: [ Heaper BLAST: #IntroduceFailed ]. "now do some more to cause a grow." tab at: 4 introduce: Tester. tab at: 5 introduce: PrimIndexTableTester. tab at: 7 introduce: Recipe. tab at: 8 introduce: BootMaker. (tab get: 1) ~~ Heaper ifTrue: [ Heaper BLAST: #IntroduceFailed ]. (tab get: 2) ~~ Category ifTrue: [ Heaper BLAST: #IntroduceFailed ]. (tab get: 3) ~~ PrimIndexTable ifTrue: [ Heaper BLAST: #IntroduceFailed ]. (tab get: 4) ~~ Tester ifTrue: [ Heaper BLAST: #IntroduceFailed ]. (tab get: 5) ~~ PrimIndexTableTester ifTrue: [ Heaper BLAST: #IntroduceFailed ]. (tab get: 7) ~~ Recipe ifTrue: [ Heaper BLAST: #IntroduceFailed ]. (tab get: 8) ~~ BootMaker ifTrue: [ Heaper BLAST: #IntroduceFailed ]. "Now remove some stuff." tab remove: 7. (tab get: 1) ~~ Heaper ifTrue: [ Heaper BLAST: #RemoveFouled ]. (tab get: 2) ~~ Category ifTrue: [ Heaper BLAST: #RemoveFouled ]. (tab get: 3) ~~ PrimIndexTable ifTrue: [ Heaper BLAST: #RemoveFouled ]. (tab get: 4) ~~ Tester ifTrue: [ Heaper BLAST: #RemoveFouled ]. (tab get: 5) ~~ PrimIndexTableTester ifTrue: [ Heaper BLAST: #RemoveFouled ]. (tab get: 8) ~~ BootMaker ifTrue: [ Heaper BLAST: #RemoveFouled ].! ! !PrimPtrTableTester methodsFor: 'testing'! {void} allTestsOn: oo {ostream reference} self accessTestOn: oo! ! !PrimPtrTableTester methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !Tester subclass: #RegionTester instanceVariableNames: 'myExampleRegions {ImmuSet NOCOPY of: XnRegion}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Spaces-Integers'! (RegionTester getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !RegionTester methodsFor: 'deferred: init'! {ImmuSet of: XnRegion} initExamples self subclassResponsibility! ! !RegionTester methodsFor: 'testing'! {void} allTestsOn: oo {ostream reference} myExampleRegions _ self initExamples. self testExtraOn: oo. self testUnaryRegionOpsOn: oo. self testBinaryRegionOpsOn: oo.! {void} binaryCheck: a {XnRegion} with: b {XnRegion} | anb {XnRegion} amb {XnRegion} aub {XnRegion} | anb _ a intersect: b. (anb isEqual: (b intersect: a)) assert: 'intersect test failed.'. (anb isSubsetOf: a) assert: 'intersect/subset test failed.'. (anb isSubsetOf: b) assert: 'intersect/subset test failed.'. (a intersects: b) == anb isEmpty not assert: 'intersects test failed.'. amb _ a minus: b. (amb intersects: b) not assert: 'minus/intersect test failed.'. (amb isSubsetOf: a) assert: 'minus/subset test failed.'. aub _ a unionWith: b. (aub isEqual: (b unionWith: a)) assert: 'unionWith test failed.'. (a isSubsetOf: aub) assert: 'union/subset test failed.'. (b isSubsetOf: aub) assert: 'union/subset test failed.'. (((a isSubsetOf: b) and: [b isSubsetOf: a]) == (a isEqual: b)) assert: 'subset/equals test failed.'.! {void} testBinaryRegionOpsOn: oo {ostream reference} myExampleRegions stepper forEach: [:one {XnRegion} | myExampleRegions stepper forEach: [:two {XnRegion} | one hashForEqual <= two hashForEqual ifTrue: [ Heaper problems.AllBlasts handle: [ :ex | | prob {Problem} | 'prob = &PROBLEM(ex);' translateOnly. [prob _ Problem create: ex PROBLEM with: ex parameter with: ex initialContext sender printString with: 0] smalltalkOnly. [cerr <count() == ' << set1 count << ' '. oo << 'set1->stepper() produces: '. stomp _ set1 stepper. oo << stomp << ' and stepping produces elements: '. [stomp hasValue] whileTrue: [oo << stomp fetch << ' '. stomp step]. oo << ' '. set1 destroy! {void} test3On: oo {ostream reference} "HashSetTester runTest: #test3On:" | set1 {HashSet} set2 {HashSet} set3 {HashSet} | set1 _ HashSet make. set2 _ HashSet make. set1 introduce: (SHTO make: 'element One'). set1 introduce: (SHTO make: 'element Two'). set1 introduce: (SHTO make: 'element Three'). set2 introduce: (SHTO make: 'element One'). set2 introduce: (SHTO make: 'element Five'). oo << 'Start of test 3, set1 (copied to set3) starts as: ' << set1 << ' and set2 starts as: ' << set2 << ' '. set3 _ set1 copy cast: HashSet. set3 restrictTo: set2. oo << 'set3->restrict(set2) == ' << set3 << ' '. set3 destroy. set3 _ set1 copy cast: HashSet. set3 restrictTo: HashSet make. oo << 'set3->restrict({nullSet}) == ' << set3 << ' '. set3 destroy. set3 _ HashSet make. set3 restrictTo: set2. oo << 'set3({nullSet})->restrict(set2) == ' << set3 << ' '. set3 destroy. set3 _ set1 copy cast: HashSet. set3 storeAll: set2. oo << 'set3->storeAll(set2) == ' << set3 << ' '. set3 destroy. set3 _ set1 copy cast: HashSet. set3 wipeAll: set2. oo << 'set3->wipeAll(set2) == ' << set3 << ' '. set1 destroy. set2 destroy. set3 destroy.! {void} test4On: oo {ostream reference} "HashSetTester runTest: #test4On:" | set1 {HashSet} set3 {HashSet} | set1 _ HashSet make. set1 introduce: (SHTO make: 'One'). set1 introduce: (SHTO make: 'Two'). set1 introduce: (SHTO make: 'Three'). oo << 'Start of test 4, set1 (copied to set3) starts as: ' << set1 << ' internals: '. set1 printInternals: oo. oo << ' set1 hasMember: (SHTO make: ''One'')' << ((set1 hasMember: (SHTO make: 'One')) ifTrue: ['TRUE'] ifFalse: ['FALSE']) << '. set1 hasMember: (SHTO make: ''Two'')' << ((set1 hasMember: (SHTO make: 'Two')) ifTrue: ['TRUE'] ifFalse: ['FALSE']) << '. set1 hasMember: (SHTO make: ''Three'')' << ((set1 hasMember: (SHTO make: 'Three')) ifTrue: ['TRUE'] ifFalse: ['FALSE']) << '. '. set3 _ set1 copy cast: HashSet. set3 store: (SHTO make: 'Three'). oo << 'set3->store (''Three'') == ' << set3 << ' '. set3 destroy. set3 _ set1 copy cast: HashSet. set3 store: (SHTO make: 'Five'). oo << 'set3->store (''Five'') == ' << set3 << ' '. set3 destroy. set3 _ set1 copy cast: HashSet. set3 wipe: (SHTO make: 'Three'). oo << 'set3->wipe (''Three'') == ' << set3 << ' '. set3 destroy. set3 _ set1 copy cast: HashSet. set3 wipe: (SHTO make: 'Five'). oo << 'set3->wipe (''Five'') == ' << set3 << ' '. set3 destroy. set3 _ set1 copy cast: HashSet. oo << 'set3->remove (''Ten'') == '. ScruSet problems.NotInSet handle: [:ex | oo << 'BLAST(NotInSet)'. ^VOID] do: [set3 remove: (SHTO make: 'Ten')]. oo << set3 << ' '! {void} testCollisions: oo {ostream reference} | set1 {HashSet} | set1 _ HashSet make. oo << ' collision testing '. self printStoreOf: (SHTO make: 'tast' with: 11) in: set1 on: oo. self printStoreOf: (SHTO make: 'tbst' with: 11) in: set1 on: oo. self printStoreOf: (SHTO make: 'tcst' with: 11) in: set1 on: oo. self printStoreOf: (SHTO make: 'tdst' with: 11) in: set1 on: oo. self printStoreOf: (SHTO make: 'test' with: 11) in: set1 on: oo. self printStoreOf: (SHTO make: 'tfst' with: 11) in: set1 on: oo. self printStoreOf: (SHTO make: 'tgst' with: 11) in: set1 on: oo. self printStoreOf: (SHTO make: 'thst' with: 11) in: set1 on: oo. self printStoreOf: (SHTO make: 'tist' with: 11) in: set1 on: oo. self printStoreOf: (SHTO make: 'tjst' with: 11) in: set1 on: oo. self printStoreOf: (SHTO make: 'tkst' with: 11) in: set1 on: oo. oo << 'storing elements already present '. self printStoreOf: (SHTO make: 'test' with: 11) in: set1 on: oo. self printStoreOf: (SHTO make: 'tast' with: 11) in: set1 on: oo. self printStoreOf: (SHTO make: 'tgst' with: 11) in: set1 on: oo. oo << 'storing new element (tlst) '. self printStoreOf: (SHTO make: 'tlst' with: 11) in: set1 on: oo. self printRemoveOf: (SHTO make: 'tast' with: 11) in: set1 on: oo. self printRemoveOf: (SHTO make: 'tdst' with: 11) in: set1 on: oo. set1 destroy! {void} testOrderedDelete: oo {ostream reference} "0 to: 40 do: [:n | ((((n*7)+1) \\ 5) == 3) ifTrue: [Transcript show: 'another is '; print: ((n*7)+1); cr; endEntry]]." | testSet {HashSet} h1 {Heaper} h2 {Heaper} h3 {Heaper} h4 {Heaper} | oo << ' testing ordered hash chaining. '. testSet _ HashSet make. testSet introduce: (h1 _ SHTO make: 'seventy-eight' with: 78). testSet introduce: (h2 _ SHTO make: 'forty-three' with: 43). testSet introduce: (h3 _ SHTO make: 'eight' with: 8). oo << 'testSet now ' << testSet << ' '. ((testSet hasMember: h1) and: [(testSet hasMember: h2) and: [testSet hasMember: h3]]) ifTrue: [oo << 'all members found '] ifFalse: [ oo << 'ERROR - not all members found ']. testSet remove: h2. oo << 'remove ' << h2 << ' , testSet now ' << testSet << ' '. (testSet hasMember: h1) ifTrue: [oo << 'set still professes to contain ' << h1 << ' '] ifFalse: [oo << 'ERROR - set does not profess to contain ' << h1 << ' ']. (testSet hasMember: h3) ifTrue: [oo << 'set still professes to contain ' << h3 << ' '] ifFalse: [oo << 'ERROR - set does not profess to contain ' << h3 << ' ']. testSet introduce: (h4 _ SHTO make: 'one-hundred-thirteen' with: 113). oo << 'introduce ' << h4 << ', testSet now ' << testSet << ' '. (testSet hasMember: h1) ifTrue: [oo << 'set still professes to contain ' << h1 << ' '] ifFalse: [oo << 'ERROR - set does not profess to contain ' << h1 << ' ']. (testSet hasMember: h3) ifTrue: [oo << 'set still professes to contain ' << h3 << ' '] ifFalse: [oo << 'ERROR - set does not profess to contain ' << h3 << ' '].! ! !HashSetTester methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !Tester subclass: #SetTableTester instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-SetTable'! (SetTableTester getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); add: #NOT.A.TYPE; yourself)! !SetTableTester methodsFor: 'tests'! {void} allTestsOn: oo {ostream reference} self simpleAccess: oo. self test1on: oo. self growTestOn: oo. self growTest2On: oo. self stepTestOn: oo.! {void} growTest2On: oo {ostream reference} | tab {SetTable} keyPile {ScruSet} valuePile {ScruSet} oc {IntegerVar} | keyPile _ self testKeys. valuePile _ self testValues. oo << 'start of grow test 2, add key->value associations in a different order '. tab _ SetTable make: self testCS. oc _ IntegerVar0. valuePile stepper forEach: [:val {Heaper} | keyPile stepper forEach: [:key {Position} | tab count = oc ifFalse: [oo << 'table count wrong before store!! ' << tab << ' ']. tab at: key introduce: val. oc _ oc + 1. tab count = oc ifFalse: [oo << 'table count wrong after store!! ' << tab << ' ']. (tab count = (self manualCount: tab)) ifFalse: [oo << 'manual count doesn''t match count!! ' << tab << ' ']]]. oo << 'end of grow test 2, table now: ' << tab << ' now - remove all those entries, use a different order than the introduce order '. keyPile stepper forEach: [:key2 {Position} | valuePile stepper forEach: [:val2 {Heaper} | tab count = oc ifFalse: [oo << 'table count wrong before remove!! ' << tab << ' ']. tab remove: key2 with: val2. oc _ oc - 1. tab count = oc ifFalse: [oo << 'table count wrong after remove!! ' << tab << ' ']. (tab count = (self manualCount: tab)) ifFalse: [oo << 'manual count doesn''t match count!! ' << tab << ' ']]]. oo << ' end of remove test. ta ta!! '! {void} growTestOn: oo {ostream reference} | tab {SetTable} keyPile {ScruSet} valuePile {ScruSet} oc {IntegerVar} | keyPile _ self testKeys. valuePile _ self testValues. oo << 'start of grow test, keys = ' << keyPile << ' and values = ' << valuePile << ' '. tab _ SetTable make: self testCS. oc _ IntegerVar0. keyPile stepper forEach: [:key {Position} | valuePile stepper forEach: [:val {Heaper} | tab count = oc ifFalse: [oo << 'table count wrong before store!! ' << tab << ' ']. tab at: key introduce: val. oc _ oc + 1. tab count = oc ifFalse: [oo << 'table count wrong after store!! ' << tab << ' ']. (tab count = (self manualCount: tab)) ifFalse: [oo << 'manual count doesn''t match count!! ' << tab << ' ']]]. oo << 'end of grow test, table now: ' << tab << ' and the domain is: ' << tab domain << ' now - remove all those entries!! '. keyPile stepper forEach: [:key2 {Position} | valuePile stepper forEach: [:val2 {Heaper} | tab count = oc ifFalse: [oo << 'table count wrong before remove!! ' << tab << ' ']. tab remove: key2 with: val2. oc _ oc - 1. tab count = oc ifFalse: [oo << 'table count wrong after remove!! ' << tab << ' ']. (tab count = (self manualCount: tab)) ifFalse: [oo << 'manual count doesn''t match count!! ' << tab << ' ']]]. oo << ' end of remove test. ta ta!! '! {void} simpleAccess: oo {ostream reference} | tab {SetTable} | tab _ SetTable make: IntegerSpace make. oo << 'Introduce I(2) at I(1). '. tab at: 1 integer introduce: 2 integer. oo << 'Retrieve all from 1: '. (tab stepperAtInt: 1) forEach: [:elem {Heaper} | oo << ' ' << elem << ' ']. oo << ' '. oo << 'Introduce I(2) at I(1) again and catch the blast. '. (MuTable problems.AlreadyInTable) handle: [:ex | oo << 'Blasted while introducing. '. ex return] do: [tab at: 1 integer introduce: 2 integer. oo << 'Should have blasted on second introduce. ']. oo << 'Store I(3) at 1. '. tab atInt: 1 store: 3 integer. oo << 'Retrieve all from I(1): '. (tab stepperAt: 1 integer) forEach: [:elem2 {Heaper} | oo << ' ' << elem2 << ' ']. oo << ' '. oo << 'Store I(4) at 1. '. tab atInt: 1 store: 4 integer. oo << 'Retrieve all from 1: '. (tab stepperAtInt: 1) forEach: [:elem3 {Heaper} | oo << ' ' << elem3 << ' ']. oo << ' '. oo << 'Table is now: ' << tab << ' Remove I(3) at I(1). '. tab remove: 1 integer with: 3 integer. oo << 'Table is now: ' << tab << ' '.! {void} stepTestOn: oo {ostream reference} | stepr {Stepper} keyPile {ScruSet of: Position} valuePile {ScruSet of: Heaper} tab {SetTable} | oo << 'Test fetching of steppers (stepper at a key). '. keyPile _ self testKeys. valuePile _ self testValues. tab _ SetTable make: self testCS. keyPile stepper forEach: [:key {Position} | valuePile stepper forEach: [:val {Heaper} | tab at: key introduce: val]]. keyPile stepper forEach: [:key2 {Position} | | valSet {MuSet} | valSet _ self testValues asMuSet. stepr _ tab stepperAt: key2. oo << 'stepper for key ' << key2 << ' is ' << stepr << ' '. stepr forEach: [:val3 {Heaper} | valSet remove: val3]. valSet isEmpty not ifTrue: [oo << 'valSet contains ' << valSet << ' ']]. oo << 'end of stepperAt: test '.! {void} test1on: oo {ostream reference} | tab1 {SetTable} stp {TableStepper} | tab1 _ SetTable make: IntegerSpace make. oo << 'table is now ' << tab1 << ' '. tab1 at: 1 integer store: (Sequence string: 'abcd'). tab1 at: 1 integer store: (Sequence string: 'abce'). tab1 at: 1 integer store: (Sequence string: 'abcf'). tab1 at: 1 integer store: (Sequence string: 'abcg'). tab1 at: 1 integer store: (Sequence string: 'abch'). tab1 at: 1 integer store: (Sequence string: 'abci'). oo << 'tab1 is now ' << tab1 << ' '. tab1 at: 2 integer store: (Sequence string: 'abcd'). tab1 at: 2 integer store: (Sequence string: 'abce'). tab1 at: 2 integer store: (Sequence string: 'abcf'). tab1 at: 2 integer store: (Sequence string: 'abcg'). tab1 at: 2 integer store: (Sequence string: 'abch'). tab1 at: 2 integer store: (Sequence string: 'abci'). oo << 'tab1 is now ' << tab1 << ' '. tab1 at: 3 integer store: (Sequence string: 'abcd'). tab1 at: 3 integer store: (Sequence string: 'abce'). tab1 at: 3 integer store: (Sequence string: 'abcf'). tab1 at: 3 integer store: (Sequence string: 'abcg'). tab1 at: 3 integer store: (Sequence string: 'abch'). tab1 at: 3 integer store: (Sequence string: 'abci'). oo << 'tab1 is now ' << tab1 << ' '. oo << ' contents of table are: '. (stp _ tab1 stepper) forEach: [:elem {Heaper} | oo << 'tab1 fetch: ' << stp position << ' == ' << elem << ' ']! ! !SetTableTester methodsFor: 'private: testing'! {IntegerVar} lastTestValue ^ 9! {IntegerVar} manualCount: table {SetTable} | cnt {IntegerVar} | cnt _ IntegerVar0. table stepper forEach: [:elem {Heaper} | elem ~~ NULL ifTrue: [cnt _ cnt + 1]]. "kill st80 'elem not used' msg" ^ cnt! {CoordinateSpace} testCS ^ SequenceSpace make! {ScruSet of: Position} testKeys | keys {MuSet of: Position} | keys _ MuSet make. keys introduce: (Sequence string: 'fghijklmna'). keys introduce: (Sequence string: 'fghijklmnb'). keys introduce: (Sequence string: 'fghijklmnc'). keys introduce: (Sequence string: 'fghijklmnd'). keys introduce: (Sequence string: 'fghijklmne'). keys introduce: (Sequence string: 'fghijklmao'). keys introduce: (Sequence string: 'fghijklmbo'). keys introduce: (Sequence string: 'fghijklmco'). keys introduce: (Sequence string: 'fghijklmdo'). keys introduce: (Sequence string: 'fghijklmeo'). keys introduce: (Sequence string: 'fghijklano'). keys introduce: (Sequence string: 'fghijklbno'). keys introduce: (Sequence string: 'fghijklcno'). keys introduce: (Sequence string: 'fghijkldno'). keys introduce: (Sequence string: 'fghijkleno'). keys introduce: (Sequence string: 'fghijkamno'). keys introduce: (Sequence string: 'fghijkbmno'). keys introduce: (Sequence string: 'fghijkcmno'). keys introduce: (Sequence string: 'fghijkdmno'). keys introduce: (Sequence string: 'fghijkemno'). keys introduce: (Sequence string: 'fghijalmno'). keys introduce: (Sequence string: 'fghijblmno'). keys introduce: (Sequence string: 'fghijclmno'). keys introduce: (Sequence string: 'fghijdlmno'). keys introduce: (Sequence string: 'fghijelmno'). keys introduce: (Sequence string: 'fghiaklmno'). keys introduce: (Sequence string: 'fghibklmno'). keys introduce: (Sequence string: 'fghicklmno'). keys introduce: (Sequence string: 'fghidklmno'). keys introduce: (Sequence string: 'fghieklmno'). keys introduce: (Sequence string: 'fghajklmno'). keys introduce: (Sequence string: 'fghbjklmno'). keys introduce: (Sequence string: 'fghcjklmno'). keys introduce: (Sequence string: 'fghdjklmno'). keys introduce: (Sequence string: 'fghejklmno'). keys introduce: (Sequence string: 'fgaijklmno'). keys introduce: (Sequence string: 'fgbijklmno'). keys introduce: (Sequence string: 'fgcijklmno'). keys introduce: (Sequence string: 'fgdijklmno'). keys introduce: (Sequence string: 'fgeijklmno'). keys introduce: (Sequence string: 'fahijklmno'). keys introduce: (Sequence string: 'fbhijklmno'). keys introduce: (Sequence string: 'fchijklmno'). keys introduce: (Sequence string: 'fdhijklmno'). keys introduce: (Sequence string: 'fehijklmno'). keys introduce: (Sequence string: 'aghijklmno'). keys introduce: (Sequence string: 'bghijklmno'). keys introduce: (Sequence string: 'cghijklmno'). keys introduce: (Sequence string: 'dghijklmno'). keys introduce: (Sequence string: 'eghijklmno'). ^ keys! {ScruSet of: Heaper} testValues | vals {MuSet of: IntegerPos} | vals _ MuSet make. IntegerVar0 to: self lastTestValue do: [:ti {IntegerVar} | vals introduce: (ti integer)]. ^ vals! ! !SetTableTester methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !Tester subclass: #SetTester instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Testing'! (SetTester getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); yourself)! !SetTester methodsFor: 'testing'! {void} allTestsOn: oo {ostream reference} | aTester {Tester} | aTester _ HashSetTester create. aTester allTestsOn: oo. aTester _ ImmuSetTester create. aTester allTestsOn: oo! ! !SetTester methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !Tester subclass: #ShepherdLockTester instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-sheph'! (ShepherdLockTester getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); yourself)! !ShepherdLockTester methodsFor: 'testing'! {void} allTestsOn: oo {ostream reference} "ShepherdLockTester runTest" | conn {Connection} | conn _ Connection make: Counter. self test1On: oo. conn destroy! {void} test1On: oo {ostream reference} "ShepherdLockTester runTest: #test1On:" | aLocked {ShepherdLocked} anUnlocked {ShepherdLocked} stackPtrs {PrimPtrTable} | stackPtrs _ StackExaminer pointersOnStack. aLocked _ ShepherdLocked makeLocked. anUnlocked _ ShepherdLocked makeUnlocked. oo << 'aLocked Shepherd '. [(stackPtrs fetch: aLocked asOop) == NULL ifFalse: [oo << 'is locked'] ifTrue: [oo << 'is not locked']] smalltalkOnly. 'if (stackPtrs->fetch((Int32)(void*)aLocked) == NULL) { oo << "is locked"; } else { oo << "is not locked"; }' translateOnly. aLocked isReallyUnlocked ifFalse: [oo << '; is really locked'] ifTrue: [oo << '; is really not locked']. oo << ' anUnlocked Shepherd '. [(stackPtrs fetch: anUnlocked asOop) == NULL ifFalse: [oo << 'is locked'] ifTrue: [oo << 'is not locked']] smalltalkOnly. 'if (stackPtrs->fetch((Int32)(void*)anUnlocked) == NULL) { oo << "is locked"; } else { oo << "is not locked"; }' translateOnly. anUnlocked isReallyUnlocked ifFalse: [oo << '; is really locked'] ifTrue: [oo << '; is really not locked']. oo << ' '.! ! !ShepherdLockTester methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !Tester subclass: #ShuffleTester instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Xcvr'! ShuffleTester comment: 'test the ByteShufflers '! (ShuffleTester getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); yourself)! !ShuffleTester methodsFor: 'testing'! {void} test1On: aStream {ostream reference} "self tryTest: #test1On:" | simpleString {UInt8Array} shuffler {ByteShuffler} copy {UInt8Array} | shuffler _ SimpleShuffler create. simpleString _ UInt8Array string: 'abcdefghijkl'. copy _ simpleString copy cast: UInt8Array. shuffler shuffle: 16 with: copy gutsOf with: 6. copy noMoreGuts. aStream << ' Shuffling 16: ' << simpleString << ' to: ' << copy << ' '. copy _ simpleString copy cast: UInt8Array. shuffler shuffle: 32 with: copy gutsOf with: 3. copy noMoreGuts. aStream << 'Shuffling 32: ' << simpleString << ' to: ' << copy << ' '. simpleString _ UInt8Array string: ''. copy _ simpleString copy cast: UInt8Array. shuffler shuffle: 16 with: copy gutsOf with: Int32Zero. copy noMoreGuts. aStream << 'Shuffling an empty string 16: ' << copy << ' '. copy _ simpleString copy cast: UInt8Array. shuffler shuffle: 32 with: copy gutsOf with: Int32Zero. copy noMoreGuts. aStream << 'Shuffling an empty string 32: ' << copy << ' '. copy _ UInt8Array string: 'ab'. shuffler shuffle: 16 with: copy gutsOf with: 1. copy noMoreGuts. aStream << 'Shuffling a tiny string 16: ' << copy << ' '. simpleString _ UInt8Array string: 'abcd'. copy _ simpleString copy cast: UInt8Array. shuffler shuffle: 32 with: copy gutsOf with: 1. copy noMoreGuts. aStream << 'Shuffling a tiny string 32: ' << copy << ' '. copy _ simpleString copy cast: UInt8Array. shuffler shuffle: 16 with: copy gutsOf with: 2. copy noMoreGuts. aStream << 'Shuffling a small string 16: ' << copy << ' '. copy _ UInt8Array string: 'abcdef'. shuffler shuffle: 16 with: copy gutsOf with: 3. copy noMoreGuts. aStream << 'Shuffling a small string 16: ' << copy << ' '.! ! !ShuffleTester methodsFor: 'running tests'! {void} allTestsOn: aStream {ostream reference} "ShuffleTester runTest" aStream << 'testing shuffler '. self test1On: aStream.! ! !ShuffleTester methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !Tester subclass: #TableEntryTester instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-tabent'! TableEntryTester comment: 'test entries in isolation just for fun'! (TableEntryTester getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); yourself)! !TableEntryTester methodsFor: 'testing'! {void} allTestsOn: oo {ostream reference} "A regression test is run by calling this method. What the tester writes to 'oo' is actually written to file *o.txt and compared against an approved reference file (*r.txt) of what this tester once used to output. If they match exactly, then the test is passed. Otherwise, someone needs to manually understand why they're different. The diff is in file *d.txt. It is strongly recommended (in order to avoid regression errors) that when a tester is extended to test something new that its output also be extended with some result of the new test. The extended test will then fail the first time. The programmer should verify that the reason for failure is exactly that the tester now additionally outputs the correct results of the new test, in which case this output should be made into the new reference output and the test run again." self test1on: oo. self test2on: oo. self test3on: oo.! {void} test1on: oo {ostream reference} | ent1 {TableEntry} | oo << 'start of test 1 - basic stuff '. ent1 _ TableEntry make: (Sequence string: 'one') with: (Sequence string: 'two'). oo << ' ent1 == ' << ent1 << '; key is ' << ent1 position << '; and value is ' << ent1 value << '; next is ' << ent1 fetchNext << ' '. oo << ' test match of ent1 with ' << (Sequence string: 'one') << ': '. (ent1 match: (Sequence string: 'one')) ifTrue: [oo << 'TRUE'] ifFalse: [oo << 'FALSE']. oo << ' test match of ent1 with ' << (Sequence string: 'two') << ': '. (ent1 match: (Sequence string: 'two')) ifTrue: [oo << 'TRUE'] ifFalse: [oo << 'FALSE']. oo << ' test matchValue of ent1 with ' << (Sequence string: 'one') << ': '. (ent1 matchValue: (Sequence string: 'one')) ifTrue: [oo << 'TRUE'] ifFalse: [oo << 'FALSE']. oo << ' test matchValue of ent1 with ' << (Sequence string: 'two') << ': '. (ent1 matchValue: (Sequence string: 'two')) ifTrue: [oo << 'TRUE'] ifFalse: [oo << 'FALSE']. oo << ' end of test one '! {void} test2on: oo {ostream reference} | ent1 {TableEntry} ent2 {TableEntry} ent3 {TableEntry} | oo << 'start of test 2 - linking stuff '. ent1 _ TableEntry make: (Sequence string: 'one') with: (Sequence string: 'value'). oo << ' ent1 == ' << ent1 << '; key is ' << ent1 position << '; and value is ' << ent1 value << '; next is ' << ent1 fetchNext << ' '. ent2 _ TableEntry make: (Sequence string: 'two') with: (Sequence string: 'value'). oo << ' ent2 == ' << ent2 << '; key is ' << ent2 position << '; and value is ' << ent2 value << '; next is ' << ent2 fetchNext << ' '. ent3 _ TableEntry make: (Sequence string: 'three') with: (Sequence string: 'value'). oo << ' ent3 == ' << ent3 << '; key is ' << ent3 position << '; and value is ' << ent3 value << '; next is ' << ent3 fetchNext << ' '. ent1 setNext: ent2. ent2 setNext: ent3. oo << 'ent1 next now: ' << ent1 fetchNext. oo << ' ent2 next now: ' << ent2 fetchNext. oo << ' ent3 next now: ' << ent3 fetchNext << ' '. "oo << 'step over chain: '. ent1 stepper forEach: [:ent {TableEntry} | oo << 'entry is ' << ent << ' ']."! {void} test3on: oo {ostream reference} | ent1 {TableEntry} ent2 {TableEntry} ent3 {TableEntry} ent4 {TableEntry} | [IntegerPos] USES. oo << 'start of test 2 - different entry types '. ent1 _ TableEntry make: (Sequence string: 'one') with: (Sequence string: 'value'). oo << ' ent1 == ' << ent1 << '; key is ' << ent1 position << '; and value is ' << ent1 value << '; next is ' << ent1 fetchNext << ' '. ent2 _ TableEntry make: (1 integer) with: (Sequence string: 'value'). oo << ' ent2 == ' << ent2 << '; key is ' << ent2 position << '; and value is ' << ent2 value << '; next is ' << ent2 fetchNext << ' '. ent2 _ TableEntry make.IntegerVar: 1 with: (Sequence string: 'value'). oo << ' ent2 == ' << ent2 << '; key is ' << ent2 position << '; and value is ' << ent2 value << '; next is ' << ent2 fetchNext << ' '. ent3 _ TableEntry make: (HeaperAsPosition make: (Sequence string: 'three')) with: (Sequence string: 'three'). oo << ' ent3 == ' << ent3 << '; key is ' << ent3 position << '; and value is ' << ent3 value << '; next is ' << ent3 fetchNext << ' '. ent4 _ TableEntry make: (Sequence string: 'value') hashForEqual integer with: (Sequence string: 'value'). oo << ' ent4 == ' << ent4 << '; key is ' << ent4 position << '; and value is ' << ent4 value << '; next is ' << ent4 fetchNext << ' '. ent4 _ TableEntry make.IntegerVar: (Sequence string: 'value') hashForEqual with: (Sequence string: 'value'). oo << ' ent4 == ' << ent4 << '; key is ' << ent4 position << '; and value is ' << ent4 value << '; next is ' << ent4 fetchNext << ' '.! ! !TableEntryTester methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !Tester subclass: #VolumeTester instanceVariableNames: 'myConnection {Connection NOCOPY}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-nkernel'! (VolumeTester getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); add: #SMALLTALK.ONLY; yourself)! !VolumeTester methodsFor: 'testing'! {void} allTestsOn: oo {ostream reference} | server file protoArray count chunk result stepper | Dean shouldImplement. "bring this up to date" myConnection := Connection make: FeServer. server _ myConnection bootHeaper. protoArray _ UInt8Array basicNew. file _ (Filename named: 'base.cha') readStream. result _ FeEdition empty: IntegerSpace make. [count _ 0. chunk _ 41000. 50 timesRepeat: [| data {UInt8Array} | oo << count << ' '. data _ file next: chunk. data changeClassToThatOf: protoArray. result _ result combine: ((server newEdition: data) transformedBy: (IntegerMapping make: count)). count _ count + chunk]. result domain. stepper _ RandomStepper make: 389. 120 timesRepeat: [| start {IntegerVar} stop {IntegerVar} region {XnRegion} | start _ stepper value \\ count. stepper step. stop _ stepper value \\ count. stepper step. region _ IntegerRegion make: start with: stop. oo << region << ' '. result copy: region]. 200 timesRepeat: [| start {IntegerVar} stop {IntegerVar} region {XnRegion} | start _ stepper value \\ count. stepper step. stop _ stepper value \\ 30000. stop > count ifTrue: [stop _ count]. stepper step. region _ IntegerRegion make: start with: stop. oo << region << ' '. result retrieve: region with: NULL]] valueNowOrOnUnwindDo: [file close]! ! !VolumeTester methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !Tester subclass: #WorksTester instanceVariableNames: ' myConnection {Connection NOCOPY} myCR {Character star NOCOPY} myTestID {ID NOCOPY}' classVariableNames: 'TheTester {WorksTester} ' poolDictionaries: '' category: 'Xanadu-nkernel'! (WorksTester getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); yourself)! !WorksTester methodsFor: 'testing'! {void} allTestsOn: oo {ostream reference} | testID {ID} | myConnection := Connection make: FeServer. myConnection bootHeaper. CurrentKeyMaster fluidSet: ((FeServer loginByName: (WorksTester sequence: 'Test')) cast: BooLock) boo. CurrentKeyMaster fluidGet incorporate: FeKeyMaster makePublic. testID := WorksTester clubID: (WorksTester sequence: 'Test'). InitialOwner fluidSet: testID. InitialReadClub fluidSet: testID. InitialEditClub fluidSet: testID. InitialSponsor fluidSet: testID. CurrentAuthor fluidSet: testID. self makeEditionTestOn: oo. self editionTestOn: oo. [CurrentPacker fluidGet destroyAbandoned] smalltalkOnly. self crossTestOn: oo. self compareTestOn: oo. [CurrentPacker fluidGet destroyAbandoned] smalltalkOnly. self globalIDTestOn: oo. [CurrentPacker fluidGet destroyAbandoned] smalltalkOnly. self workTestOn: oo. self endorseTestOn: oo. [CurrentPacker fluidGet destroyAbandoned] smalltalkOnly. self historyTestOn: oo. self sponsorTestOn: oo. [CurrentPacker fluidGet destroyAbandoned] smalltalkOnly. self kmTestOn: oo. self transclusionsTestOn: oo. [CurrentPacker fluidGet destroyAbandoned] smalltalkOnly. self transcludersBugTestOn: oo. self ownerTestOn: oo. [CurrentPacker fluidGet destroyAbandoned] smalltalkOnly. self labelTestOn: oo. [CurrentPacker fluidGet destroyAbandoned] smalltalkOnly. FeServer waitForWrite: (WorksWaitDetector make: oo with: 'Test done!!').! ! !WorksTester methodsFor: 'tests'! {void} compareTestOn: oo {ostream reference} "Test the various version comparision operations" | a {FeEdition} b {FeEdition} work1 {FeWork} work2 {FeWork} work3 {FeWork} edn {FeEdition} region {XnRegion} | a := FeEdition placeHolders: (IntegerRegion interval: Int32Zero with:100). b := (((a copy: (IntegerSpace make below: (IntegerPos make: 50) with: false)) transformedBy: (IntegerSpace make translation: 100)) combine: (FeEdition placeHolders: (IntegerSpace make interval: (IntegerPos make: Int32Zero) with: (IntegerPos make: 50)))) combine: ((a copy: (IntegerSpace make interval: (IntegerPos make: 25) with: (IntegerPos make: 75))) transformedBy: (IntegerSpace make translation: 25)). oo << 'a sharedWith b: ' << (a sharedWith: b) << myCR << 'a notSharedWith b: ' << (a notSharedWith: b) << myCR << 'a sharedRegion b: ' << (a sharedRegion: b) << myCR << 'a mapSharedTo b: ' << (a mapSharedTo: b) << myCR << 'a sharedRegion b copy [120,130): ' << (a sharedRegion: (b copy: (IntegerRegion make: 120 with: 130))) << myCR << 'a keysOf a[50]: ' << (a positionsOf: (a get: (IntegerPos make: 50))) << myCR << 'b sharedWith a: ' << (b sharedWith: a) << myCR << 'b notSharedWith a: ' << (b notSharedWith: a) << myCR << 'b mapSharedTo a: ' << (b mapSharedTo: a) << myCR << 'b sharedRegion a: ' << (b sharedRegion: a) << myCR << 'b sharedRegion a copy [20,30): ' << (b sharedRegion: (a copy: (IntegerRegion make: 20 with: 30))) << myCR << 'b positionsOf a[50]: ' << (b positionsOf: (a get: (IntegerPos make: 50))) << myCR. work1 := FeWork make: (FeText make: (UInt8Array string: 'foo')) edition. work2 := FeWork make: (FeEdition fromOne: Int32Zero integer with: work1). edn := FeEdition fromOne: Int32Zero integer with: work1. work3 := work2 edition theOne cast: FeWork. region := edn positionsOf: work3. oo << 'region = ' << region << myCR.! {void} crossTestOn: oo {ostream reference} | four {PtrArray} is {IDSpace} cross {CrossSpace} doc {FeEdition} | oo << myCR << 'CrossSpace retrieval test' <= 10' << myCR. (doc copy: (cross extrusion: j with: (IntegerSpace make above: (IntegerPos make: 10) with: true))) retrieve forEach: [ :bundle {FeElementBundle} | oo << 'found ' << bundle element << ' at ' << bundle region << myCR]].! {void} editionTestOn: oo {ostream reference} "Test the simple Edition operations" | edition {FeEdition} | oo << 'Testing various Edition operations' << myCR. edition := FeEdition empty: IntegerSpace make. oo << 'initially: ' << edition << myCR << ' coordinateSpace: ' << edition coordinateSpace << myCR << ' count: ' << edition count << myCR << ' domain: ' << edition domain << myCR << ' isEmpty: ' << edition isEmpty << myCR << ' isFinite: ' << edition isFinite << myCR. edition := edition with: (IntegerPos make: Int32Zero) with: FeRangeElement placeHolder. oo << 'with(0): ' << edition << myCR << ' theOne: ' << edition theOne << myCR. edition := edition withAll: (IntegerSpace make above: (IntegerPos make: 1) with: true) with: (FeDataHolder make: (PrimIntValue make: 65)). oo << 'withAll: ' << edition << myCR << ' domain: ' << edition domain << myCR << ' isEmpty: ' << edition isEmpty << myCR << ' isFinite: ' << edition isFinite << myCR. oo << 'stepper:' << myCR. [ScruTable] USES. (edition stepper: (IntegerSpace make interval: (IntegerPos make: IntegerVarZero) with: (IntegerPos make: 2))) forPositions: [ :p {Position} :v {FeRangeElement} | oo << ' ' << p << ' -> ' << v << myCR]. edition := edition without: (IntegerPos make: 3). oo << 'without 3' << edition << myCR. edition := edition withoutAll: (IntegerSpace make above: (IntegerPos make: 2) with: true). oo << 'withoutAll: ' << edition << myCR << ' count: ' << edition count << myCR << ' domain: ' << edition domain << myCR << ' isEmpty: ' << edition isEmpty << myCR << ' isFinite: ' << edition isFinite << myCR << ' get 1: ' << (edition get: (IntegerPos make: 1)) << myCR. oo << 'combined: ' << (edition combine: (FeEdition fromOne: (IntegerPos make: 5) with: FeRangeElement placeHolder)) << myCR. oo << 'replaced: ' << (edition replace: (FeEdition fromOne: (IntegerPos make: 1) with: FeRangeElement placeHolder)) << myCR.! {void} endorseTestOn: oo {ostream reference} "Test endorsing and unendorsing Editions and Works" | e1 {FeEdition} w1 {FeWork} iD {ID} userRegion {IDRegion} | e1 := FeEdition empty: IntegerSpace make. w1 := FeWork make: e1. oo << 'Initial endorsements:' << myCR << ' on Edition: ' << e1 endorsements << myCR << ' on Work: ' << w1 endorsements << myCR << myCR. userRegion _ CurrentAuthor fluidGet asRegion cast: IDRegion. e1 endorse: (FeServer endorsementRegion: userRegion with: userRegion). iD := IDSpace global newID. w1 endorse: (FeServer endorsementRegion: userRegion with: (iD asRegion cast: IDRegion)). oo << 'After endorsing:' << myCR << ' on Edition: ' << e1 endorsements << myCR << ' on Work: ' << w1 endorsements << myCR. e1 retract: (FeServer endorsementRegion: userRegion with: userRegion). w1 retract: (FeServer endorsementRegion: userRegion with: (iD asRegion cast: IDRegion)). oo << 'After unendorsing:' << myCR << ' on Edition: ' << e1 endorsements << myCR << ' on Work: ' << w1 endorsements << myCR.! {void} globalIDTestOn: oo {ostream reference} "Test assigning and retrieving by global IDs" | p1 {FeRangeElement as: FePlaceHolder} id1a {ID} id1b {ID} ids {IDRegion} p2 {FeRangeElement as: FePlaceHolder} id2 {ID} ed {FeEdition} | p1 := FeRangeElement placeHolder. (ids := FeServer iDsOf: p1) isEmpty ifFalse: [oo << 'Newly created place holder ' << p1 << ' should not have had any IDs but was reported to have ' << ids << myCR]. id1a := FeServer assignID: p1. ((ids := FeServer iDsOf: p1) isEqual: id1a asRegion) ifFalse: [oo << 'PlaceHolder ' << p1 << ' should have IDs ' << id1a asRegion << ' but was reported to have IDs ' << ids << myCR]. id1b := FeServer assignID: p1. ((ids := FeServer iDsOf: p1) isEqual: (id1a asRegion with: id1b)) ifFalse: [oo << 'PlaceHolder ' << p1 << ' should have IDs ' << (id1a asRegion with: id1b) << ' but was reported to have IDs ' << ids << myCR]. p2 := FeRangeElement placeHolder. id2 := FeServer assignID: p2. ed := (FeEdition fromOne: (IntegerPos make: Int32Zero) with: p1) combine: (FeEdition fromOne: (IntegerPos make: 1) with: p2). ((ids := FeServer iDsOfRange: ed) isEqual: ((id1a asRegion with: id1b) with: id2)) ifFalse: [oo << 'PlaceHolders ' << ed << ' should have IDs ' << ((id1a asRegion with: id1b) with: id2) << ' but was reported to have IDs ' << ids << myCR]. oo << 'Global ID assignment test successful '! {void} historyTestOn: oo {ostream reference} | work {FeWork} | work _ FeWork make: (FeEdition fromArray: (WorksTester string: 'Howdy doody.')). work setHistoryClub: FeServer publicClubID. work revise: (FeEdition fromArray: (WorksTester string: 'Good bye')). work revise: (FeEdition fromArray: (WorksTester string: 'Much better.')). oo << 'The trail is: ' << work revisions << myCR. work revisions stepper forPositions: [:position {Position} :value {FeWork} | oo << position << '->' << (value edition retrieve theOne cast: FeArrayBundle) array << myCR]. "self halt." oo << myCR.! {void} kmTestOn: oo {ostream reference} "Test the operation of KeyMasters" | km {FeKeyMaster} clubspec {FeWrapperSpec} test {FeClub} club1 {FeClub} detect1 {FeStatusDetector} work1 {FeWork} club2 {FeClub} detect2 {FeStatusDetector} work2 {FeWork} desc {FeClubDescription} | km := CurrentKeyMaster fluidGet copy. CurrentKeyMaster fluidBind: km during: [clubspec := FeWrapperSpec get: (WorksTester sequence: 'ClubDescription'). test := (FeServer get: CurrentAuthor fluidGet) cast: FeClub. club1 := FeClub make: (FeClubDescription make: FeSet make with: FeBooLockSmith make) edition. oo << 'Club1 ' << (FeServer iDOf: club1) << ' is initially ' << (clubspec wrap: club1 edition) << myCR << 'and CurrentKeyMaster is ' << km actualAuthority << myCR << myCR. oo << 'Logged in as ' << ((FeServer login: (FeServer iDOf: club1)) cast: BooLock) boo. club2 := FeClub make: (FeClubDescription make: FeSet make with: FeBooLockSmith make) edition. oo << 'Club 2 ' << (FeServer iDOf: club2) << ' is initially ' << (clubspec wrap: club2 edition) << myCR << 'and CurrentKeyMaster is ' << km actualAuthority << myCR << myCR. InitialEditClub fluidBind: (FeServer iDOf: club1) during: [InitialReadClub fluidBind: (FeServer iDOf: club1) during: [work1 := FeWork make: (FeEdition empty: IntegerSpace make)]]. detect1 := (WorksTestStatusDetector make: oo with: ' Work 1'). work1 addStatusDetector: detect1. oo << 'Giving Work 1 edit authority to Club 1' << myCR. work1 requestGrab. InitialEditClub fluidBind: (FeServer iDOf: club2) during: [work2 := FeWork make: (FeEdition empty: IntegerSpace make)]. detect2 := (WorksTestStatusDetector make: oo with: ' Work 2'). work2 addStatusDetector: detect2. oo << 'Giving Work 2 edit authority to Club 2' << myCR. work2 requestGrab. desc := (clubspec wrap: club1 edition) cast: FeClubDescription. club1 revise: (desc withMembership: (desc membership with: test)) edition. oo << 'Club 1 should now have Test as a member: ' << (clubspec wrap: club1 edition) << myCR << 'So CurrentKeyMaster should have Club 1 authority: ' << km actualAuthority << myCR << 'and Work 1 should have become grabbed: ' << work1 canRevise << myCR << myCR. desc := (clubspec wrap: club2 edition) cast: FeClubDescription. club2 revise: (desc withMembership: (desc membership with: club1)) edition. oo << 'Club 2 should now have Club 1 as a member: ' << (clubspec wrap: club2 edition) << myCR << 'So CurrentKeyMaster should have Club 2 authority: ' << km actualAuthority << myCR << 'and Work 2 should have become grabbed: ' << work2 canRevise << myCR << myCR. desc := (clubspec wrap: club2 edition) cast: FeClubDescription. club2 revise: (desc withMembership: ((desc membership without: club1) with: (FeServer get: FeServer publicClubID))) edition. oo << 'Club 2 should have Public but not Club 1 as a member: ' << (clubspec wrap: club2 edition) << myCR << 'So CurrentKeyMaster should retain Club 2 authority: ' << km actualAuthority << myCR << 'and Work 2 should remain grabbed: ' << work2 canRevise << myCR << myCR. km removeLogins: (FeServer publicClubID asRegion cast: IDRegion). oo << 'The combined KeyMaster should have lost Public & Club 2 authority: ' << ' login ' << km loginAuthority << myCR << ' actual ' << km actualAuthority << myCR << 'and Work 2 should have become released but readable:' << ' canRevise ' << work2 canRevise << ' canRead ' << work2 canRead << myCR << myCR. desc := (clubspec wrap: club1 edition) cast: FeClubDescription. club1 revise: (desc withMembership: (desc membership without: test)) edition. oo << 'Club 1 should no longer have Test as a member: ' << (clubspec wrap: club1 edition) << myCR << 'So CurrentKeyMaster should not have Club 1 authority: ' << km actualAuthority << myCR << 'and Work 1 should have become released and unreadable:' << ' canRevise ' << work1 canRevise << ' canRead ' << work1 canRead << myCR << myCR. "work2 removeStatusDetector: detect2." "work1 removeStatusDetector: detect1." club1 release. club2 release]. self thingToDo. "Clean up persistent information in Server"! {void} labelTestOn: oo {ostream reference} | edition {FeEdition} e1 {FeEdition} e2 {FeEdition} e3 {FeEdition} e4 {FeEdition} e1prime {FeEdition} edition2 {FeEdition} | e1 _ FeEdition fromArray: (WorksTester string: 'First Edition'). e2 _ FeEdition fromArray: (WorksTester string: 'Second Edition'). e3 _ FeEdition fromArray: (WorksTester string: 'Third Edition'). e4 _ FeEdition fromArray: (WorksTester string: 'Fourth Edition'). edition _ FeEdition fromArray: (PrimSpec pointer arrayWithThree: e1 with: e2 with: (FeWork make: e1)). oo << 'Labels:' << myCR. oo << ' ' << e1 label << ' ' << e2 label << ' ' << e3 label << ' ' << e4 label << myCR. oo << 'labelled e1: '<< (edition positionsLabelled: e1 label) << myCR. e1prime _ ((edition fetch: (IntegerPos make: IntegerVarZero)) cast: FeEdition) with: (IntegerPos make: 1) with: FeRangeElement placeHolder. edition2 _ edition with: (IntegerPos make: IntegerVarZero) with: e1prime. oo << 'edit e1: ' << (edition2 positionsLabelled: e1 label) << myCR. oo << 'labelled e2: ' << (edition2 positionsLabelled: e2 label) << myCR. oo << 'rebind e2: ' << ((edition2 rebind: (IntegerPos make: 1) with: e3) positionsLabelled: e2 label) << myCR. oo << 'duplicate e1: ' << ((edition2 with: (IntegerPos make: 1) with: e1) positionsLabelled: e1 label) << myCR. oo << myCR.! {void} makeEditionTestOn: oo {ostream reference} "Try making Editions in a variety of ways" | edn {FeEdition} place {FeRangeElement} data {FeDataHolder} bits {PrimArray} | oo << (edn := FeEdition empty: SequenceSpace make) << myCR << (FeEdition empty: IntegerSpace make) << myCR. oo << (FeEdition placeHolders: (IntegerSpace make interval: (IntegerPos make: IntegerVarZero) with: (IntegerPos make: 10))) << myCR << (FeEdition placeHolders: SequenceSpace make emptyRegion) << myCR << (FeEdition placeHolders: SequenceSpace make fullRegion) << myCR. data := FeDataHolder make: (PrimIntValue make: 3). place := FeRangeElement placeHolder. oo << (FeEdition fromOne: (IntegerPos make: IntegerVarZero) with: edn) << myCR << (FeEdition fromOne: (IntegerPos make: 1) with: place) << myCR << (FeEdition fromOne: (IntegerPos make: 2) with: data) << myCR. oo << (FeEdition fromAll: (IntegerSpace make above: (IntegerPos make: 10) with: true) with: edn) << myCR << (FeEdition fromAll: (IntegerSpace make below: (IntegerPos make: 100) with: false) with: place) << myCR << (FeEdition fromAll: IntegerSpace make emptyRegion with: place) << myCR << (FeEdition fromAll: IDSpace unique fullRegion with: data) << myCR. oo << (FeEdition fromArray: (WorksTester string: '')) << myCR. oo << (FeEdition fromArray: (WorksTester string: 'hello world')) << myCR. bits := WorksTester string: 'hello world!!'. oo << (FeEdition fromArray: bits) << myCR << (FeEdition fromArray: bits with: (IntegerSpace make interval: (IntegerPos make: 10) with: (IntegerPos make: 22))) << myCR "<< (FeEdition fromArray: bits with: NULL with: IntegerSpace make getDescending) << myCR << (FeEdition fromArray: bits with: (IntegerSpace make interval: (IntegerPos make: 100) with: (IntegerPos make: 113)) with: IntegerSpace make getDescending) << myCR". oo << 'Making Editions test finished' << myCR << myCR.! {void} ownerTestOn: oo {ostream reference} | work {FeWork} club {FeClub} edition {FeEdition} | club := (FeServer get: FeServer publicClubID) cast: FeClub. oo << 'Club: ' << club << ' owned by: ' << club owner << myCR. InitialOwner fluidBind: CurrentAuthor fluidGet during: [work _ FeWork make: (FeEdition fromArray: (WorksTester string: 'The one I can change.'))]. oo << 'Work: ' << work << ' owned by: ' << work owner << myCR. edition _ FeEdition fromArray: (PrimSpec pointer arrayWithTwo: work with: club) with: ((WorksTester sequence: 'changeable') asRegion with: (WorksTester sequence: 'permanent')) with: SequenceSpace make ascending. oo << 'Set owners of: ' << edition << myCR. oo << 'result: ' << (edition setRangeOwners: FeServer publicClubID) << myCR. oo << 'Club: ' << club << ' owned by: ' << club owner << myCR. oo << 'Work: ' << work << ' owned by: ' << work owner << myCR. oo << myCR.! {void} sponsorTestOn: oo {ostream reference} "Test the sponsoring mechanism" | club {FeClub} testClub {FeClub} blank {FeEdition} w1 {FeWork} w2 {FeWork} | testClub := (FeServer get: CurrentAuthor fluidGet) cast: FeClub. club := FeClub make: (FeClubDescription make: (FeSet make: ((PrimSpec pointer arrayWith: (FeServer get: CurrentAuthor fluidGet)) cast: PtrArray)) with: FeWallLockSmith make) edition. blank := FeEdition fromArray: (UInt8Array string:'blank'). w1 := FeWork make: blank. FeServer assignID: w1. w2 := FeWork make: blank. FeServer assignID: w1. oo << 'Initially ' << myCR << 'sponsored by Test: ' << testClub sponsoredWorks << myCR << 'sponsored by new: ' << club sponsoredWorks << myCR << 'work 1 sponsors: ' << w1 sponsors << myCR << 'work 2 sponsors: ' << w2 sponsors << myCR. w1 sponsor: (CurrentAuthor fluidGet asRegion cast: IDRegion). w2 sponsor: ((CurrentAuthor fluidGet asRegion with: (FeServer iDOf: club)) cast: IDRegion). oo << 'After sponsoring ' << myCR << 'sponsored by Test: ' << testClub sponsoredWorks << myCR << 'sponsored by new: ' << club sponsoredWorks << myCR << 'work 1 sponsors: ' << w1 sponsors << myCR << 'work 2 sponsors: ' << w2 sponsors << myCR. w1 unsponsor: (CurrentAuthor fluidGet asRegion cast: IDRegion). w2 unsponsor: ((CurrentAuthor fluidGet asRegion with: (FeServer iDOf: club)) cast: IDRegion). oo << 'After unsponsoring ' << myCR << 'sponsored by Test: ' << testClub sponsoredWorks << myCR << 'sponsored by new: ' << club sponsoredWorks << myCR << 'work 1 sponsors: ' << w1 sponsors << myCR << 'work 2 sponsors: ' << w2 sponsors << myCR. self thingToDo. "test authority checks" self thingToDo. "get rid of persistent info"! {void} transcludersBugTestOn: oo {ostream reference} | text {FeText} refs {FeEdition} work {FeWork} detector {FeFillRangeDetector} container {FeEdition} text2 {FeText} values {PtrArray} | oo << myCR << myCR << 'Transcluders bug test' << myCR << myCR. "Test a bug in the transcluders mechanism: if E1 = {x -> E2}, then E1 transcluders will be triggered by an Edition containing E2" text := FeText make: ((WorksTester string: 'oops') cast: PrimDataArray). container := FeEdition fromOne: 1 integer with: text edition. refs := container transcluders: (FeWrapperSpec get: (WorksTester sequence: 'HyperRef')) filter. detector := WorksTestFillRangeDetector make: oo with: 'Should not have been transcluded by '. refs addFillRangeDetector: detector. work := FeWork make: (FeSingleRef make: text edition) edition. refs removeFillRangeDetector: detector. "if E1 = {x -> E2, y -> E3}, then E1 transcluders may be triggered by another separately created Edition containing E1 & E2?" values := PtrArray nulls: 2. text2 := FeText make: ((WorksTester string: 'oops') cast: PrimDataArray). values at: UInt32Zero store: text edition. values at: 1 store: text2 edition. container := FeEdition fromArray: values. refs := container transcluders: (FeWrapperSpec get: (WorksTester sequence: 'HyperRef')) filter. refs addFillRangeDetector: detector. work revise: (FeEdition fromArray: values). refs removeFillRangeDetector: detector.! {void} transclusionsTestOn: oo {ostream reference} "Test the transclusions query" | text {FeText} n {IntegerVar} texts {FeEdition} refs {FeEdition} detector {FeFillRangeDetector} work {FeWork} interval {IntegerRegion} | oo << myCR << myCR << 'Transclusions test' << myCR << myCR. text := FeText make: ((WorksTester string: '(abcdefghijklmnopqrstuvwxyz)') cast: PrimDataArray). n := text count. work := FeWork make: (FeSingleRef make: text edition) edition. texts := text edition rangeTranscluders: NULL with: (FeWrapperSpec get: (WorksTester sequence: 'Text')) filter. refs := text edition rangeTranscluders: NULL with: (FeWrapperSpec get: (WorksTester sequence: 'HyperRef')) filter. detector := WorksTestFillRangeDetector make: oo with: 'Transcluded by '. texts addFillRangeDetector: detector. refs addFillRangeDetector: detector. interval _ IntegerSpace make interval: (IntegerPos make: (n // 2)) with: (IntegerPos make: n). text := text move: IntegerVarZero with: interval. work revise: (FeSingleRef make: text edition) edition. text := text extract: ((IntegerRegion integerExtent: n // 4 with: n // 4) complement cast: IntegerRegion). work revise: (FeSingleRef make: text edition) edition. text := text insert: n // 2 with: (FeText make: (((WorksTester string: '[ABCDEFGHIJKLMNOPQRSTUVWXYZ]')) cast: PrimDataArray)). work revise: (FeSingleRef make: text edition) edition. texts := text edition rangeTranscluders: interval with: (FeWrapperSpec get: (WorksTester sequence: 'Text')) filter with: NULL with: Int32Zero with: texts. refs := text edition rangeTranscluders: interval with: (FeWrapperSpec get: (WorksTester sequence: 'HyperRef')) filter with: NULL with: Int32Zero with: refs. text := text extract: (IntegerSpace make above: (IntegerPos make: n // 2) with: true). work revise: (FeSingleRef make: text edition) edition. text := text extract: (IntegerSpace make below: (IntegerPos make: n) with: false). work revise: (FeSingleRef make: text edition) edition. text := text move: IntegerVarZero with: interval. work revise: (FeSingleRef make: text edition) edition. texts removeFillRangeDetector: (detector cast: FeFillRangeDetector). refs removeFillRangeDetector: (detector cast: FeFillRangeDetector).! {void} workTestOn: oo {ostream reference} "Try the various operations on Works" | e1 {FeEdition} w1 {FeWork} km {FeKeyMaster} | e1 := FeEdition fromArray: (WorksTester string: 'hello world'). w1 := FeWork make: e1. self dumpWorkOn: oo with: 'As newly created ' with: w1. w1 addStatusDetector: (WorksTestStatusDetector make: oo with: ' Work 1'). w1 release. self dumpWorkOn: oo with: 'With authority restored' with: w1. w1 grab. self dumpWorkOn: oo with: 'Grabbed' with: w1. CurrentKeyMaster fluidBind: ((FeServer loginByName: (Sequence string: 'Test')) cast: BooLock) boo during: [w1 grab. self dumpWorkOn: oo with: 'Grabbed again' with: w1]. w1 requestGrab. self dumpWorkOn: oo with: 'Grab requested again' with: w1. w1 release. self dumpWorkOn: oo with: 'Released' with: w1. km := FeKeyMaster makePublic. CurrentKeyMaster fluidBind: km during: [w1 requestGrab. self dumpWorkOn: oo with: 'Grab requested yet again' with: w1. km incorporate: ((FeServer loginByName: (Sequence string: 'Test')) cast: BooLock) boo. self dumpWorkOn: oo with: 'KeyMaster incorporated' with: w1]. km removeLogins: (CurrentAuthor fluidGet asRegion cast: IDRegion). self dumpWorkOn: oo with: 'KeyMaster login removed' with: w1.! ! !WorksTester methodsFor: 'private:'! {void} dumpWorkOn: oo {ostream reference} with: tag {char star} with: work {FeWork} "Print the state and contents of a Work" oo << myCR << tag << '['. work canRead ifTrue: [oo << work edition]. work canRevise ifTrue: [oo << ' (grabbed)']. oo << ']'! ! !WorksTester methodsFor: 'hooks:'! {void RECEIVE.HOOK} restartWorksTester: rcvr {Rcvr unused default: NULL} myConnection := NULL. myCR := ' '! ! !WorksTester methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. self restartWorksTester: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! WorksTester class instanceVariableNames: ''! (WorksTester getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); yourself)! !WorksTester 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)! {IntegerPos} integer: val {IntegerVar} ^ IntegerPos make: val! {Sequence} sequence: string {char star} ^ Sequence string: string! {PrimArray} string: string {char star} ^UInt8Array string: string! ! !WorksTester class methodsFor: 'smalltalk: init'! linkTimeNonInherited TheTester := NULL! staticTimeNonInherited "PrServer defineFluid: #ClientServer with: XuPromise emulsion with: [NULL]"! !Thunk subclass: #WorksIniter instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-appmods'! WorksIniter comment: 'The purpose of WorksIniter is to do the one-time initialization of clubs and homedocs to prepare a backend for ordinary client use. It is pretty sparse right now, but will eventually have much more stuff'! (WorksIniter getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(COPY boot ); yourself)! !WorksIniter methodsFor: 'initialization'! {void} initializeClubs | testClub {FeClub} testID {ID} | "Make an autonomous Test club" testClub := FeClub make: (FeClubDescription make: FeSet make with: FeBooLockSmith make) edition. testID := FeServer iDOf: testClub. testClub setReadClub: testID. testClub setEditClub: testID. testClub setSignatureClub: testID. testClub setOwner: testID. FeServer nameClub: (Sequence string: 'Test') with: testID. FeServer enableAccess: testID.! {void} initializeSystem | aConnection {Connection} adminID {ID} wwd {FeWaitDetector} | [Transcript nextPutAll: 'creating connection'; cr; endEntry] smalltalkOnly. aConnection := Connection make: FeServer. CurrentKeyMaster fluidSet: ((FeServer loginByName: (Sequence string: 'System Admin')) cast: BooLock) boo. CurrentKeyMaster fluidGet incorporate: FeKeyMaster makePublic. adminID := FeServer clubID: (Sequence string: 'System Admin'). InitialOwner fluidSet: adminID. InitialReadClub fluidSet: adminID. InitialEditClub fluidSet: adminID. InitialSponsor fluidSet: adminID. CurrentAuthor fluidSet: adminID. self initializeClubs. wwd := WorksWaitDetector create: cerr with: 'WorksInit done!!'. FeServer waitForWrite: wwd. [DiskManager] USES. CurrentPacker fluidGet purge. [Transcript nextPutAll: 'exiting'; cr; endEntry] smalltalkOnly. aConnection destroy! ! !WorksIniter methodsFor: 'execute'! {void} execute self initializeSystem! ! !WorksIniter methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !Heaper subclass: #TokenSource instanceVariableNames: ' myAvailable {Int32Array} myAvailableCount {Int32} myCeiling {Int32}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-tokens'! TokenSource comment: 'Manage a set of integerVars as tokens. The Available array is tokens that have been returned to the pool. They get used in preference to allocating new ones so that we keep the numbers dense.'! (TokenSource getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; yourself)! !TokenSource methodsFor: 'accessing'! {void} returnToken: token {Int32} token == myCeiling ifTrue: [ myCeiling _ myCeiling - 1. ^VOID ]. myAvailableCount >= myAvailable count ifTrue: [ myAvailable _ (myAvailable copyGrow: myAvailableCount+1) cast: Int32Array. ]. myAvailable at: myAvailableCount storeInt: token. myAvailableCount _ myAvailableCount + 1.! {Int32} takeToken |tmp {Int32}| myAvailableCount > Int32Zero ifTrue: [ myAvailableCount _ myAvailableCount - 1. tmp _myAvailable intAt: myAvailableCount. ] ifFalse: [ myCeiling _ myCeiling + 1. tmp _myCeiling ]. [tmp == NULL ifTrue:[self halt]] smalltalkOnly. ^tmp! ! !TokenSource methodsFor: 'creation'! create super create. myAvailable _ Int32Array make: 10. myAvailableCount _ Int32Zero. myCeiling _ Int32Zero! ! !TokenSource methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TokenSource class instanceVariableNames: ''! (TokenSource getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; yourself)! !TokenSource class methodsFor: 'creation'! make ^TokenSource create! !Heaper subclass: #TracePosition instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Traces'! (TracePosition getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !TracePosition methodsFor: 'testing'! {UInt32} actualHashForEqual "Hash based on both the branch and position." self subclassResponsibility! {BooleanVar} isEqual: another {Heaper} self subclassResponsibility! {BooleanVar} isLE: another {TracePosition} self subclassResponsibility! ! !TracePosition methodsFor: 'accessing'! {BranchDescription} branch self subclassResponsibility! {void} cacheIn: navCache {PrimIndexTable} self subclassResponsibility! {TracePosition} newSuccessor self subclassResponsibility! {TracePosition} newSuccessorAfter: tracePos {TracePosition} "Return a new tracePosition that is after both the receiver and tracePos." self subclassResponsibility! {UInt32} position self subclassResponsibility! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TracePosition class instanceVariableNames: ''! (TracePosition getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !TracePosition class methodsFor: 'pseudo-constructors'! make: branch {BranchDescription} with: position {UInt32} ^BoundedTrace create: branch with: position! !TracePosition subclass: #BoundedTrace instanceVariableNames: ' myBranch {BranchDescription} myPosition {UInt32}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Traces'! BoundedTrace comment: 'Trace Positions represent absolute coordinates in a tree-ordered space. The ent navigates to O-roots from H-roots in the northern direction using TracePositions. Refer to the Ent document for a description of the current implementation. TracePositions are generated by asking another tracePosition for a newSuccesor. The starting tracePosition is the initil TraceTree. It corresponds to branch 1, position 1.'! (BoundedTrace getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !BoundedTrace methodsFor: 'testing'! {UInt32} actualHashForEqual "This isn't used now. It might be later. Hash based on both the branch and position This hash uses a couple of arbitrary primes." ^(myBranch hashForEqual + myPosition * 10993) bitAnd: 134217727 "2^27-1"! {BooleanVar} isEqual: another {Heaper} another cast: BoundedTrace into: [:bt | ^(myBranch isEqual: bt branch) and: [myPosition == bt position]] others: [^false]. ^false "fodder"! {BooleanVar} isLE: another {TracePosition} "Return true if the two positions are comparable and the receiver is less than the argument. The argument is put in the cache so that many comparisons IN THE SAME ORDER will occur very fast. This could probably check for both tracePositions in the cache for speed even when the arguments are swapped." ^myBranch does: myPosition include: another! ! !BoundedTrace methodsFor: 'accessing'! {BranchDescription} branch "This should only be accessible in this module." ^myBranch! {void} cacheIn: navCache {PrimIndexTable} "Cache the nav-data for the receiver in navCache." | oldValue {IntegerVar} | oldValue _ navCache fetch: myBranch. oldValue == -1 ifTrue: [navCache at: myBranch store: myPosition. myBranch cacheRecur: navCache] ifFalse: [navCache at: myBranch store: (oldValue max: myPosition)].! {TracePosition} newSuccessor "Return a new successor to the receiver. The first successor is on the same branch with a higher position. Further successors are alllocated in a binary-tree fashion along a new branch." self knownBug. "This consistent count is upperbound over 12 runs of works test. It does not seem to be bound." DiskManager consistent: 14 with: [^myBranch createAfter: self]! {TracePosition} newSuccessorAfter: trace {TracePosition} "Return a new tracePosition that is after both the receiver and tracePos." self knownBug. "This consistent count is upperbound over 12 runs of works test. It does not seem to be bound." DiskManager consistent: 14 with: [| branch {BranchDescription} | branch _ myBranch makeBranch: self with: trace. myBranch installBranch: branch after: self. (trace quickCast: BoundedTrace) branch installBranch: branch after: trace. ^branch nextPosition]! {UInt32} position "This should only be accessible in this module." ^myPosition! {ImmuSet of: TracePosition} successors "Return all the successors of the receiver." ^myBranch successorsOf: self! ! !BoundedTrace methodsFor: 'smalltalk:'! {void} inspect | seen | seen _ Set new. EntView openOn: (TreeBarnacle new buildOn: self gettingChildren: [:tracePos | (seen includes: tracePos) ifTrue: [OrderedCollection new] ifFalse: [seen add: tracePos. tracePos successors asOrderedCollection]] gettingImage: [:tracePos | tracePos printString asDisplayText] at: 0 @ 0 vertical: false separation: 10 @ 10)! {void} printOn: aStream {Stream} (myPosition = 1 and: [myBranch isKindOf: DagBranch]) ifTrue: [aStream << '>']. aStream << myBranch << '.' << myPosition! ! !BoundedTrace methodsFor: 'create'! create: br {BranchDescription} with: pos {UInt32} super create. myBranch _ br. myPosition _ pos! ! !BoundedTrace methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myBranch _ receiver receiveHeaper. myPosition _ receiver receiveUInt32.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myBranch. xmtr sendUInt32: myPosition.! !Heaper subclass: #TransferSpecialist instanceVariableNames: 'myCookbook {Cookbook}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Xcvr'! (TransferSpecialist getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #EQ; yourself)! !TransferSpecialist methodsFor: 'cookbook'! {Category} getCategoryFor: no {IntegerVar} ^myCookbook getCategoryFor: no! {Recipe} getRecipe: cat {Category} ^myCookbook getRecipe: cat! {IntegerVar} numberOfCategory: cat {Category} ^myCookbook numberOfCategory: cat! ! !TransferSpecialist methodsFor: 'communication'! {Heaper} receiveHeaper: cat {Category} from: rcvr {SpecialistRcvr} "Return an object from the rcvr or NULL if cat is not a category that we handle specially." "Make sure all objects created get rcvr registerIbid: called on them so that the rcvr doesn't get out of sync." self subclassResponsibility! {void} receiveHeaper: cat {Category} into: memory {Heaper} from: rcvr {SpecialistRcvr} "Return an object from the rcvr or NULL if cat is not a category that we handle specially." self subclassResponsibility! {void} sendHeaper: hpr {Heaper} to: xmtr {SpecialistXmtr} "Transmit heapers on xmtr. Subclasses intercept and handle special cases here." xmtr startInstance: hpr with: hpr getCategory. hpr sendSelfTo: xmtr. xmtr endInstance! ! !TransferSpecialist methodsFor: 'creation'! create: aBook {Cookbook} super create. myCookbook _ aBook! ! !TransferSpecialist methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TransferSpecialist class instanceVariableNames: ''! (TransferSpecialist getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #EQ; yourself)! !TransferSpecialist class methodsFor: 'creation'! make: aBook {Cookbook} "Return a specialist that does nothing." ^TransferGeneralist create: aBook! !TransferSpecialist subclass: #DiskCountSpecialist instanceVariableNames: 'myInsideShepherd {BooleanVar}' classVariableNames: ' MaxFlocks {Int32} MaxSnarfs {Int32} SomeSpecialists {InstanceCache} ' poolDictionaries: '' category: 'Xanadu-Snarf'! (DiskCountSpecialist getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !DiskCountSpecialist methodsFor: 'creation'! create: cookbook {Cookbook} super create: cookbook. myInsideShepherd _ false! {void} destroy (SomeSpecialists store: self) ifFalse: [super destroy]! ! !DiskCountSpecialist methodsFor: 'communication'! {Heaper} receiveHeaper: cat {Category unused} from: rcvr {SpecialistRcvr unused} "DiskCountSpecialist are only for sending." Heaper BLAST: #IncompleteAbstraction. ^NULL! {void} receiveHeaper: cat {Category unused} into: memory {Heaper unused} from: rcvr {SpecialistRcvr unused} "DiskCountSpecialist are only for sending." Heaper BLAST: #IncompleteAbstraction! {void} sendHeaper: hpr {Heaper} to: xmtr {SpecialistXmtr} "Handle sending Shepherds specially." hpr cast: Abraham into: [:abe | myInsideShepherd ifTrue: [abe getInfo. "Test to verify that all persistently pointed-at sheps didi newShepherd." xmtr startInstance: abe with: abe getShepherdStubCategory. xmtr sendUInt32: abe hashForEqual. [xmtr sendCategory: (abe isStub ifTrue: [abe getCategoryFromStub] ifFalse: [abe getCategory])] smalltalkOnly. xmtr sendUInt32: MaxSnarfs. xmtr sendUInt32: MaxFlocks. xmtr endInstance] ifFalse: [myInsideShepherd _ true. super sendHeaper: abe to: xmtr. myInsideShepherd _ false]. ^VOID] others: [super sendHeaper: hpr to: xmtr]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DiskCountSpecialist class instanceVariableNames: ''! (DiskCountSpecialist getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !DiskCountSpecialist class methodsFor: 'creation'! {TransferSpecialist} make: aBook {Cookbook} | result {Heaper} | result := SomeSpecialists fetch. result == NULL ifTrue: [^self create: aBook] ifFalse: [^(self new.Become: result) create: aBook]! ! !DiskCountSpecialist class methodsFor: 'smalltalk: initialization'! initTimeNonInherited SomeSpecialists := InstanceCache make: 16! linkTimeNonInherited MaxSnarfs _ 3000000. MaxFlocks _ 3000000. SomeSpecialists := NULL! !TransferSpecialist subclass: #DiskSpecialist instanceVariableNames: ' myPacker {DiskManager} myInsideShepherd {BooleanVar}' classVariableNames: 'SomeSpecialists {InstanceCache} ' poolDictionaries: '' category: 'Xanadu-Xcvr'! (DiskSpecialist getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !DiskSpecialist methodsFor: 'communication'! {Heaper} receiveHeaper: cat {Category} from: rcvr {SpecialistRcvr} "There's a lot of smalltalk only stuff in here. Smalltalk stubs should move towards c++ stubs." | snarfID {SnarfID} index {Int32} hash {UInt32} result {Heaper} newCat {Category smalltalk} | (cat isEqualOrSubclassOf: Abraham) not ifTrue: [^rcvr basicReceive: (self getRecipe: cat)]. myInsideShepherd not ifTrue: [myInsideShepherd _ true. result _ rcvr basicReceive: (self getRecipe: cat). myInsideShepherd _ false. ^result]. hash _ rcvr receiveUInt32. [newCat _ rcvr receiveCategory] smalltalkOnly. snarfID _ rcvr receiveUInt32. index _ rcvr receiveUInt32. result _ myPacker fetchCanonical: hash with: snarfID with: index. result == NULL ifTrue: [[result _ ShepherdStub create: hash with: newCat] smalltalkOnly. [result _ ((self getRecipe: cat) cast: StubRecipe) parseStub: rcvr with: hash] translateOnly. result ~~ NULL assert: 'Bad Stub'. myPacker registerStub: (result cast: Abraham) with: snarfID with: index]. rcvr registerIbid: result. ^result! {void} receiveHeaper: cat {Category} into: memory {Heaper} from: rcvr {SpecialistRcvr} "Return an object from the rcvr or NULL if cat is not a category that we handle specially." (cat isEqualOrSubclassOf: Abraham) ifTrue: [((self getRecipe: cat) isKindOf: StubRecipe) ifTrue: [Heaper BLAST: #NotBecomable] ifFalse: [myInsideShepherd not ifTrue: [myInsideShepherd _ true. rcvr basicReceive: (self getRecipe: cat) into: memory. myInsideShepherd _ false. ^VOID]]]. rcvr basicReceive: (self getRecipe: cat) into: memory! {void} sendHeaper: hpr {Heaper} to: xmtr {SpecialistXmtr} "Handle sending Shepherds specially." hpr cast: Abraham into: [:abe | myInsideShepherd ifTrue: [abe getInfo. "Test to verify that all persistently pointed-at sheps didi newShepherd." xmtr startInstance: abe with: abe getShepherdStubCategory. xmtr sendUInt32: abe hashForEqual. [xmtr sendCategory: (abe isStub ifTrue: [abe getCategoryFromStub] ifFalse: [abe getCategory])] smalltalkOnly. xmtr sendUInt32: abe getInfo snarfID. xmtr sendUInt32: abe getInfo index. xmtr endInstance] ifFalse: [myInsideShepherd _ true. super sendHeaper: abe to: xmtr. myInsideShepherd _ false]. ^VOID] others: [super sendHeaper: hpr to: xmtr]! ! !DiskSpecialist methodsFor: 'create'! create: cookbook {Cookbook} with: packer {DiskManager} super create: cookbook. myPacker _ packer. myInsideShepherd _ false! {void} destroy (SomeSpecialists store: self) ifFalse: [super destroy]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DiskSpecialist class instanceVariableNames: ''! (DiskSpecialist getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !DiskSpecialist class methodsFor: 'smalltalk: init'! initTimeNonInherited SomeSpecialists := InstanceCache make: 16! linkTimeNonInherited SomeSpecialists := NULL! ! !DiskSpecialist class methodsFor: 'stream creation'! {TransferSpecialist} make: book {Cookbook} with: packer {DiskManager} | result {Heaper} | result := SomeSpecialists fetch. result == NULL ifTrue: [^self create: book with: packer] ifFalse: [^(self new.Become: result) create: book with: packer]! !TransferSpecialist subclass: #TransferGeneralist instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Xcvr'! (TransferGeneralist getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !TransferGeneralist methodsFor: 'create'! create: aBook {Cookbook} super create: aBook.! ! !TransferGeneralist methodsFor: 'communication'! {Heaper} receiveHeaper: cat {Category} from: rcvr {SpecialistRcvr} "No special cases. Punt to the rcvr." ^rcvr basicReceive: (self getRecipe: cat)! {void} receiveHeaper: cat {Category} into: memory {Heaper} from: rcvr {SpecialistRcvr} "No special cases. Punt to the rcvr." rcvr basicReceive: (self getRecipe: cat) into: memory! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TransferGeneralist class instanceVariableNames: ''! (TransferGeneralist getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !TransferGeneralist class methodsFor: 'creation'! {TransferSpecialist} make: aBook {Cookbook} ^self create: aBook! !Heaper subclass: #TransitionEdge instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-EdgeRegion'! TransitionEdge comment: 'Clients of EdgeManager define concrete subclasses of this, which are then used by the EdgeManager code'! (TransitionEdge getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #COPY; yourself)! !TransitionEdge methodsFor: 'accessing'! {TransitionEdge} ceiling: other {TransitionEdge} (other isGE: self) ifTrue: [^other] ifFalse: [^self]! {TransitionEdge} floor: other {TransitionEdge} (self isGE: other) ifTrue: [^other] ifFalse: [^self]! ! !TransitionEdge methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! {BooleanVar} follows: pos {Position} "Whether the position is strictly less than this edge" self subclassResponsibility! {BooleanVar} isEqual: other {Heaper} self subclassResponsibility! {BooleanVar} isFollowedBy: next {TransitionEdge} "Whether there is precisely one position between this edge and the next one" self subclassResponsibility! {BooleanVar} isGE: other {TransitionEdge} "Defines a full ordering among all edges in a given CoordinateSpace" self subclassResponsibility! {BooleanVar} touches: other {TransitionEdge} "Whether this edge touches the same position the other does" self subclassResponsibility! ! !TransitionEdge methodsFor: 'printing'! {void} printTransitionOn: oo {ostream reference} with: entering {BooleanVar} with: touchesPrevious {BooleanVar} "Print a description of this transition" self subclassResponsibility! ! !TransitionEdge methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !TransitionEdge subclass: #RealEdge instanceVariableNames: 'myPos {RealPos}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-tumbler'! (RealEdge getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #COPY; yourself)! !RealEdge methodsFor: 'accessing'! {RealPos} position ^myPos! ! !RealEdge methodsFor: 'testing'! {UInt32} actualHashForEqual ^myPos hashForEqual bitXor: self getCategory hashForEqual! {BooleanVar} follows: pos {Position} self subclassResponsibility! {BooleanVar} isEqual: other {Heaper} self subclassResponsibility! {BooleanVar} isFollowedBy: next {TransitionEdge} self subclassResponsibility! {BooleanVar} isGE: other {TransitionEdge} self subclassResponsibility! {BooleanVar} touches: other {TransitionEdge} ^myPos isEqual: (other cast: RealEdge) position! ! !RealEdge methodsFor: 'printing'! {void} printTransitionOn: oo {ostream reference} with: entering {BooleanVar} with: touchesPrevious {BooleanVar} self subclassResponsibility! ! !RealEdge methodsFor: 'creation'! create: pos {RealPos} super create. myPos := pos.! ! !RealEdge methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myPos _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myPos.! !RealEdge subclass: #AfterReal instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-tumbler'! (AfterReal getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !AfterReal methodsFor: 'comparing'! {BooleanVar} follows: pos {Position} ^self position isGE: (pos cast: RealPos)! {BooleanVar} isEqual: other {Heaper} other cast: AfterReal into: [:after | ^self position isEqual: after position] others: [^false]. ^false "fodder"! {BooleanVar} isFollowedBy: next {TransitionEdge} ^false! {BooleanVar} isGE: other {TransitionEdge} ^self position isGE: (other cast: RealEdge) position! ! !AfterReal methodsFor: 'printing'! {void} printTransitionOn: oo {ostream reference} with: entering {BooleanVar} with: touchesPrevious {BooleanVar} oo << ' '. entering ifTrue: [oo << '(']. (touchesPrevious and: [entering not]) ifFalse: [oo << self position]. entering ifFalse: [oo << ']']! ! !AfterReal methodsFor: 'creation'! create: pos {RealPos} super create: pos.! ! !AfterReal methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AfterReal class instanceVariableNames: ''! (AfterReal getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !AfterReal class methodsFor: 'create'! {RealEdge} make: pos {RealPos} ^self create: pos! !RealEdge subclass: #BeforeReal instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-tumbler'! (BeforeReal getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !BeforeReal methodsFor: 'printing'! {void} printTransitionOn: oo {ostream reference} with: entering {BooleanVar} with: touchesPrevious {BooleanVar} oo << ' '. entering ifTrue: [oo << '[']. (touchesPrevious and: [entering not]) ifFalse: [oo << self position]. entering ifFalse: [oo << ')']! ! !BeforeReal methodsFor: 'comparing'! {BooleanVar} follows: pos {Position} ^((pos cast: RealPos) isGE: self position) not! {BooleanVar} isEqual: other {Heaper} other cast: BeforeReal into: [:after | ^self position isEqual: after position] others: [^false]. ^false "fodder"! {BooleanVar} isFollowedBy: next {TransitionEdge} next cast: AfterReal into: [:after | ^self position isEqual: after position] others: [^false]. ^false "fodder"! {BooleanVar} isGE: other {TransitionEdge} other cast: BeforeReal into: [:before | ^self position isGE: before position] cast: AfterReal into: [:after | ^(after position isGE: self position) not]. ^false "fodder"! ! !BeforeReal methodsFor: 'creation'! create: pos {RealPos} super create: pos.! ! !BeforeReal methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BeforeReal class instanceVariableNames: ''! (BeforeReal getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !BeforeReal class methodsFor: 'create'! {RealEdge} make: pos {RealPos} ^self create: pos! !TransitionEdge subclass: #SequenceEdge instanceVariableNames: 'mySequence {Sequence}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-tumbler'! (SequenceEdge getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #COPY; yourself)! !SequenceEdge methodsFor: 'testing'! {UInt32} actualHashForEqual ^self sequence hashForEqual bitXor: self getCategory hashForEqual! {BooleanVar} follows: pos {Position} "Whether the position is strictly less than this edge" self subclassResponsibility! {BooleanVar} isEqual: other {Heaper} self subclassResponsibility! {BooleanVar} isFollowedBy: next {TransitionEdge} "Whether there is precisely one position between this edge and the next one" self subclassResponsibility! {BooleanVar} isGE: other {TransitionEdge} "Defines a full ordering among all edges in a given CoordinateSpace" self subclassResponsibility! {BooleanVar} touches: other {TransitionEdge} "Whether this edge touches the same position the other does" self subclassResponsibility! ! !SequenceEdge methodsFor: 'accessing'! {Sequence} sequence ^mySequence! {SequenceEdge} transformedBy: dsp {SequenceMapping} "Transform the edge by the given mapping" self subclassResponsibility! ! !SequenceEdge methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '(' << mySequence << ')'! {void} printTransitionOn: oo {ostream reference} with: entering {BooleanVar} with: touchesPrevious {BooleanVar} "Print a description of this transition" self subclassResponsibility! ! !SequenceEdge methodsFor: 'create'! create: sequence {Sequence} super create. mySequence := sequence.! ! !SequenceEdge methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. mySequence _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: mySequence.! !SequenceEdge subclass: #AfterSequence instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-tumbler'! (AfterSequence getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !AfterSequence methodsFor: 'accessing'! {Position} position ^self sequence! {SequenceEdge} transformedBy: dsp {SequenceMapping} ^AfterSequence make: ((dsp of: self sequence) cast: Sequence)! ! !AfterSequence methodsFor: 'create'! create: sequence {Sequence} super create: sequence.! ! !AfterSequence methodsFor: 'printing'! {void} printTransitionOn: oo {ostream reference} with: entering {BooleanVar} with: touchesPrevious {BooleanVar} oo << ' '. entering ifTrue: [oo << '(']. (touchesPrevious and: [entering not]) ifFalse: [oo << self sequence]. entering ifFalse: [oo << ']']! ! !AfterSequence methodsFor: 'comparing'! {BooleanVar} follows: pos {Position} ^self sequence isGE: (pos cast: Sequence)! {BooleanVar} isEqual: other {Heaper} other cast: AfterSequence into: [ :after | ^after sequence isEqual: self sequence] others: [^false]. ^ false "compiler fodder"! {BooleanVar} isFollowedBy: next {TransitionEdge unused} ^false! {BooleanVar} isGE: other {TransitionEdge} other cast: BeforeSequencePrefix into: [ :prefix | ^(self sequence comparePrefix: prefix sequence with: prefix limit) >= Int32Zero] cast: SequenceEdge into: [ :edge | ^self sequence isGE: edge sequence]. ^ false "compiler fodder"! {BooleanVar} touches: other {TransitionEdge} other cast: BeforeSequencePrefix into: [ :prefix | ^false] cast: SequenceEdge into: [ :edge | ^self sequence isEqual: edge sequence]. ^ false "compiler fodder"! ! !AfterSequence methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AfterSequence class instanceVariableNames: ''! (AfterSequence getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !AfterSequence class methodsFor: 'pseudo constructors'! {SequenceEdge} make: sequence {Sequence} ^self create: sequence! !SequenceEdge subclass: #BeforeSequence instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-tumbler'! (BeforeSequence getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !BeforeSequence methodsFor: 'comparing'! {BooleanVar} follows: pos {Position} ^((pos cast: Sequence) isGE: self sequence) not! {BooleanVar} isEqual: other {Heaper} other cast: BeforeSequence into: [ :before | ^before sequence isEqual: self sequence] others: [^false]. ^ false "compiler fodder"! {BooleanVar} isFollowedBy: next {TransitionEdge} next cast: AfterSequence into: [ :after | ^self sequence isEqual: after sequence] others: [^false]. ^ false "compiler fodder"! {BooleanVar} isGE: other {TransitionEdge} other cast: BeforeSequencePrefix into: [ :prefix | ^(self sequence comparePrefix: prefix sequence with: prefix limit) >= Int32Zero] cast: BeforeSequence into: [ :before | ^self sequence isGE: before sequence] cast: AfterSequence into: [ :after | ^(after sequence isGE: self sequence) not]. ^ false "compiler fodder"! {BooleanVar} touches: other {TransitionEdge} other cast: BeforeSequencePrefix into: [ :prefix | ^false] cast: SequenceEdge into: [ :edge | ^self sequence isEqual: edge sequence]. ^ false "compiler fodder"! ! !BeforeSequence methodsFor: 'accessing'! {Position} position ^self sequence! {SequenceEdge} transformedBy: dsp {SequenceMapping} ^BeforeSequence make: ((dsp of: self sequence) cast: Sequence)! ! !BeforeSequence methodsFor: 'create'! create: sequence {Sequence} super create: sequence.! ! !BeforeSequence methodsFor: 'printing'! {void} printTransitionOn: oo {ostream reference} with: entering {BooleanVar} with: touchesPrevious {BooleanVar} oo << ' '. entering ifTrue: [oo << '[']. (touchesPrevious and: [entering not]) ifFalse: [oo << self sequence]. entering ifFalse: [oo << ')']! ! !BeforeSequence methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BeforeSequence class instanceVariableNames: ''! (BeforeSequence getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !BeforeSequence class methodsFor: 'pseudo constructors'! {SequenceEdge} make: sequence {Sequence} ^self create: sequence! !SequenceEdge subclass: #BeforeSequencePrefix instanceVariableNames: 'myLimit {IntegerVar}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-tumbler'! (BeforeSequencePrefix getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !BeforeSequencePrefix methodsFor: 'comparing'! {BooleanVar} follows: pos {Position} ^ (self sequence isEqual: (pos cast: Sequence)) not and: [self sequence isGE: pos]! {BooleanVar} isEqual: other {Heaper} other cast: BeforeSequencePrefix into: [ :prefix | ^myLimit = prefix limit and: [prefix sequence isEqual: self sequence]] others: [^false]. ^ false "compiler fodder"! {BooleanVar} isFollowedBy: next {TransitionEdge unused} ^false! {BooleanVar} isGE: other {TransitionEdge} | diff {Int32} | other cast: BeforeSequencePrefix into: [ :prefix | diff := self sequence comparePrefix: prefix sequence with: (myLimit min: prefix limit). diff ~= Int32Zero ifTrue: [^diff > Int32Zero]. ^myLimit >= prefix limit] cast: SequenceEdge into: [ :before | ^(self sequence comparePrefix: before sequence with: myLimit) > Int32Zero]. ^ false "compiler fodder"! {BooleanVar} touches: other {TransitionEdge} other cast: BeforeSequencePrefix into: [ :before | ^myLimit = before limit and: [(self sequence comparePrefix: before sequence with: myLimit - 1) = Int32Zero and: [((self sequence integerAt: myLimit) - (before sequence integerAt: myLimit)) abs <= 1]]] others: [^false]. ^ false "compiler fodder"! ! !BeforeSequencePrefix methodsFor: 'accessing'! {IntegerVar} limit ^myLimit! {Position} position Heaper BLAST: #NotInSpace. ^NULL "fodder"! {SequenceEdge} transformedBy: dsp {SequenceMapping} ^BeforeSequencePrefix create: ((dsp of: self sequence) cast: Sequence) with: myLimit + dsp shift! ! !BeforeSequencePrefix methodsFor: 'create'! create: sequence {Sequence} with: limit {IntegerVar} super create: sequence. myLimit := limit.! ! !BeforeSequencePrefix methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '(' << myLimit << ', ' << self sequence << ')'! {void} printTransitionOn: oo {ostream reference} with: entering {BooleanVar} with: touchesPrevious {BooleanVar} oo << ' '. entering ifTrue: [oo << '(']. (touchesPrevious and: [entering not]) ifFalse: [Ravi thingToDo. "Eliminate strings of zeros / stars, print UInt8Arrays as strings" (IntegerVarZero min: self sequence shift) to: (myLimit + 1 max: IntegerVarZero) do: [ :i {IntegerVar} | i == IntegerVarZero ifTrue: [oo << '!!'] ifFalse: [i ~= self sequence shift ifTrue: [oo << '.']]. (i = myLimit and: [entering not]) ifTrue: [oo << ((self sequence integerAt: i) - 1)] ifFalse: [i <= myLimit ifTrue: [oo << (self sequence integerAt: i)] ifFalse: [oo << '*']]]]. entering ifFalse: [oo << ')']! ! !BeforeSequencePrefix methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myLimit _ receiver receiveIntegerVar.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendIntegerVar: myLimit.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BeforeSequencePrefix class instanceVariableNames: ''! (BeforeSequencePrefix getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !BeforeSequencePrefix class methodsFor: 'pseudo constructors'! {TransitionEdge} above: sequence {Sequence} with: limit {IntegerVar} limit < sequence shift ifTrue: [^self create: (Sequence usingx: limit with: ((PrimSpec integerVar arrayWith: (PrimSpec integerVar value: 1)) cast: PrimIntegerArray)) with: limit]. limit < (sequence shift + sequence count) ifTrue: [| newCount {Int32} hisCount {Int32} | newCount _ (limit - sequence shift + 1) DOTasLong. hisCount _ sequence secretNumbers count. ^self create: (Sequence usingx: sequence shift with: (((sequence secretNumbers copy: (newCount min: hisCount) with: Int32Zero with: Int32Zero with: (newCount - hisCount max: Int32Zero)) cast: PrimIntegerArray) at: (limit - sequence shift) DOTasLong hold: (sequence integerAt: limit) + 1 with: true)) with: limit]. "Ravi knownBug." "creates huge arrays if (limit - sequence shift) is too big" ^self create: (Sequence usingx: sequence shift with: (sequence secretNumbers at: (limit - sequence shift) DOTasLong hold: (sequence integerAt: limit) + 1)) with: limit! {TransitionEdge} below: sequence {Sequence} with: limit {IntegerVar} limit < sequence shift ifTrue: [^self create: Sequence zero with: limit]. limit < (sequence shift + sequence count) ifTrue: [| newCount {Int32} hisCount {Int32} | newCount _ (limit - sequence shift + 1) DOTasLong. hisCount _ sequence secretNumbers count. ^self create: (Sequence usingx: sequence shift with: ((sequence secretNumbers copy: (newCount min: hisCount) with: Int32Zero with: Int32Zero with: (newCount - hisCount max: Int32Zero)) cast: PrimIntegerArray)) with: limit]. ^self create: sequence with: limit! !Heaper subclass: #XcvrMaker instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Xcvr'! (XcvrMaker getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !XcvrMaker methodsFor: 'xcvr creation'! {SpecialistRcvr} makeRcvr: specialist {TransferSpecialist} with: readStream {XnReadStream} self subclassResponsibility! {SpecialistXmtr} makeXmtr: specialist {TransferSpecialist} with: writeStream {XnWriteStream} self subclassResponsibility! ! !XcvrMaker methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << 'A ' << self getCategory name! ! !XcvrMaker methodsFor: 'testing'! {UInt32} actualHashForEqual ^self getCategory hashForEqual * 997 + (FHash fastHash.String: self id)! {char star} id "Return the name by which this protocol should be known." self subclassResponsibility! {BooleanVar} isEqual: other {Heaper} other cast: XcvrMaker into: [:xm | ^(String strcmp: self id with: xm id) == Int32Zero] others: [^false]. ^false "fodder"! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! XcvrMaker class instanceVariableNames: ''! (XcvrMaker getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !XcvrMaker class methodsFor: 'xcvr creation'! {XcvrMaker} make ^BogusXcvrMaker create! ! !XcvrMaker class methodsFor: 'smalltalk: initialization'! initTimeInherited | maker {XcvrMaker} | self REQUIRES: ProtocolBroker. maker _ self create. ProtocolBroker registerXcvrProtocol: maker! suppressInitTimeInherited! !XcvrMaker subclass: #Binary2XcvrMaker instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Xcvr'! (Binary2XcvrMaker getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !Binary2XcvrMaker methodsFor: 'xcvr creation'! {SpecialistRcvr} makeRcvr: specialist {TransferSpecialist} with: readStream {XnReadStream} ^Binary2Rcvr make: specialist with: readStream! {SpecialistXmtr} makeXmtr: specialist {TransferSpecialist} with: writeStream {XnWriteStream} ^Binary2Xmtr make: specialist with: writeStream! ! !Binary2XcvrMaker methodsFor: 'testing'! {char star} id ^'binary2'! ! !Binary2XcvrMaker methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Binary2XcvrMaker class instanceVariableNames: ''! (Binary2XcvrMaker getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !Binary2XcvrMaker class methodsFor: 'creation'! {XcvrMaker} make ^self create! !XcvrMaker subclass: #BogusXcvrMaker instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Xcvr'! (BogusXcvrMaker getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !BogusXcvrMaker methodsFor: 'testing'! {char star} id ^'bogus'! ! !BogusXcvrMaker methodsFor: 'xcvr creation'! {SpecialistRcvr} makeRcvr: specialist {TransferSpecialist unused} with: readStream {XnReadStream unused} Heaper BLAST: #BogusProtocol. ^NULL! {SpecialistXmtr} makeXmtr: specialist {TransferSpecialist} with: writeStream {XnWriteStream} Heaper BLAST: #BogusProtocol. ^NULL! !XcvrMaker subclass: #TextyXcvrMaker instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Xcvr'! (TextyXcvrMaker getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !TextyXcvrMaker methodsFor: 'xcvr creation'! {SpecialistRcvr} makeRcvr: specialist {TransferSpecialist} with: readStream {XnReadStream} ^TextyRcvr create: specialist with: readStream! {SpecialistXmtr} makeXmtr: specialist {TransferSpecialist} with: writeStream {XnWriteStream} ^TextyXmtr create: specialist with: writeStream! ! !TextyXcvrMaker methodsFor: 'testing'! {char star} id ^'texty'! ! !TextyXcvrMaker methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TextyXcvrMaker class instanceVariableNames: ''! (TextyXcvrMaker getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !TextyXcvrMaker class methodsFor: 'creation'! {XcvrMaker} make ^self create! {Rcvr} makeReader: stream {XnReadStream} ^TextyRcvr create: (TransferSpecialist make: (Cookbook make)) with: stream.! {Xmtr} makeWriter: stream {XnWriteStream} ^TextyXmtr create: (TransferSpecialist make: (Cookbook make)) with: stream.! !Heaper subclass: #Xmtr instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Xcvr'! (Xmtr getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #EQ; yourself)! !Xmtr methodsFor: 'sending'! {void} sendBooleanVar: b {BooleanVar} self subclassResponsibility! {void} sendHeaper: object {Heaper} self subclassResponsibility! {void} sendIEEEDoubleVar: x {IEEEDoubleVar} self subclassResponsibility! {void} sendInt32: n {Int32} self subclassResponsibility! {void} sendInt8: byte {Int8} self subclassResponsibility! {void} sendIntegerVar: n {IntegerVar} self subclassResponsibility! {void} sendString: s {char star} self subclassResponsibility! {void} sendUInt32: n {UInt32} self subclassResponsibility! {void} sendUInt8: byte {UInt8} self subclassResponsibility! {void} sendUInt8Data: array {UInt8Array} self subclassResponsibility! ! !Xmtr methodsFor: 'smalltalk: sending'! {void} send: object {Object} "Dispatch to the send routines." (object isInteger) ifTrue: [self sendIntegerVar: object] ifFalse: [object == true ifTrue: [self sendUInt32: 1] ifFalse: [object == false ifTrue: [self sendUInt32: UInt32Zero] ifFalse: [self sendHeaper: object]]]! ! !Xmtr methodsFor: 'smalltalk: deja vu'! {void} sendData: array {UInt8Array} self subclassResponsibility! ! !Xmtr methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! !Xmtr subclass: #SpecialistXmtr instanceVariableNames: ' mySpecialist {TransferSpecialist} myIbids {PrimIndexTable} myNextIbid {Int4}' classVariableNames: 'XmtrIbidCache {PrimIndexTable} ' poolDictionaries: '' category: 'Xanadu-Xcvr'! SpecialistXmtr comment: 'myIbids maps from already sent heapers to their ibid numbers.'! (SpecialistXmtr getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !SpecialistXmtr methodsFor: 'sending'! {void} sendBooleanVar: b {BooleanVar} self subclassResponsibility! {void} sendCategory: cat {Category} self subclassResponsibility! {void} sendHeaper: object {Heaper} object == NULL ifTrue: [self sendNULL] ifFalse: [| pos {Int32} | pos _ (myIbids fetch: object) DOTasLong. pos ~~ -1 ifTrue: [self sendIbid: pos] ifFalse: [mySpecialist sendHeaper: object to: self]]! {void} sendIEEEDoubleVar: x {IEEEDoubleVar} self subclassResponsibility! {void} sendInt32: n {Int32} self subclassResponsibility! {void} sendInt8: byte {Int8} self subclassResponsibility! {void} sendIntegerVar: n {IntegerVar} self subclassResponsibility! {void} sendString: s {char star} self subclassResponsibility! {void} sendUInt32: n {UInt32} self subclassResponsibility! {void} sendUInt8: byte {UInt8} self subclassResponsibility! {void} sendUInt8Data: array {UInt8Array} "Send the contents of the UInt8Array as data." self subclassResponsibility! ! !SpecialistXmtr methodsFor: 'specialist sending'! {void} endInstance self subclassResponsibility! {void} startInstance: heaper {Heaper} with: cat {Category} "Register heaper as an object to be sent across the wire, and send cat as its category. cat might be different from heaper->getCategory() if another object is being substituted for heaper." myIbids at: heaper introduce: myNextIbid. myNextIbid _ myNextIbid + 1. self startNewInstance: cat! ! !SpecialistXmtr methodsFor: 'protected:'! {void} endPacket myIbids clearAll. myNextIbid _ Int32Zero! {void} sendNULL self subclassResponsibility! {TransferSpecialist} specialist ^mySpecialist! {void} startNewInstance: cat {Category} self subclassResponsibility! ! !SpecialistXmtr methodsFor: 'private: sending'! {void} sendIbid: pos {Int32} "The object represented by pos has already been sent. Send just a reference by number." self startNewInstance: CommIbid. self sendInt32: pos. self endInstance! ! !SpecialistXmtr methodsFor: 'protected: creation'! create: specialist {TransferSpecialist} super create. mySpecialist _ specialist. XmtrIbidCache == NULL ifTrue: [myIbids _ PrimIndexTable make: 255] ifFalse: [myIbids _ XmtrIbidCache. XmtrIbidCache _ NULL]. myNextIbid _ Int32Zero! {void} destruct XmtrIbidCache == NULL ifTrue: [myIbids clearAll. XmtrIbidCache _ myIbids cast: PrimIndexTable. myIbids _ NULL] ifFalse: [myIbids destroy]. "mySpecialist destroy" super destruct! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! SpecialistXmtr class instanceVariableNames: ''! (SpecialistXmtr getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !SpecialistXmtr class methodsFor: 'smalltalk: init'! linkTimeNonInherited XmtrIbidCache _ NULL! !SpecialistXmtr subclass: #Binary2Xmtr instanceVariableNames: ' myStream {XnWriteStream} myDepth {IntegerVar}' classVariableNames: ' MaxNumberLength {Int32} NumberBuffer {UInt8 star} SomeXmtrs {InstanceCache} ' poolDictionaries: '' category: 'Xanadu-Xcvr'! (Binary2Xmtr getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !Binary2Xmtr methodsFor: 'sending'! {void} sendBooleanVar: b {BooleanVar} b ifTrue: [myStream putByte: 1] ifFalse: [myStream putByte: Int0]. self endThing! {void} sendCategory: cat {Category} self putIntegerVar: (self specialist numberOfCategory: cat) + 1. self endThing! {void} sendIEEEDoubleVar: x {IEEEDoubleVar} "Sending the normal decimal approximation doesn't work because it introduces roundoff error. What we need to do instead is send a hex encoding of the IEEE double precision (64-bit) representation of the number. For clarity in the textual protocol, we also include the decimal approximation in a comment." self unimplemented. "self putIntegerVar: x DOTmantissa. self putIntegerVar: x DOTexponent." self endThing! {void} sendInt32: n {Int32} self putIntegerVar: n. self endThing! {void} sendInt8: n {Int8} myStream putByte: (n \\ 256). self endThing! {void} sendIntegerVar: n {IntegerVar} self putIntegerVar: n. self endThing! {void} sendString: s {char star} self putIntegerVar: (Integer IntegerVar: (String strlen: s)). myStream putStr: s. self endThing! {void} sendUInt32: n {UInt32} self putIntegerVar: n. self endThing! {void} sendUInt4: n {UInt4} self putIntegerVar: n. self endThing! {void} sendUInt8: n {UInt8} myStream putByte: n. self endThing! {void} sendUInt8Data: array {UInt8Array} myStream putData: array. self endThing! ! !Binary2Xmtr methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '( ' << myStream << ')'! ! !Binary2Xmtr methodsFor: 'protected: sending'! {void} endPacket "Put in a separator pattern so we can detect the packets visually." myStream putByte: $!! uint8. myStream putByte: $!! uint8. myStream flush. super endPacket! {void} endThing myDepth <= IntegerVar0 ifTrue: [self endPacket]! {void} putIntegerVar: num {IntegerVar} "Send a Dean style humber. Like Drexler style, except all the tag bits go into the first byte." " 7/1 0<7> 14/2 10<6> <8> 21/3 110<5> <16> 28/4 1110<4> <24> 35/5 11110<3> <32> 42/6 111110<2> <40> 49/7 1111110<1> <48> 56/8 11111110 <56> ?/? 11111111 " | abs {IntegerVar} stream {XnWriteStream wimpy} val {Int32} | stream _ self stream. val _ num DOTasLong. val < Int32Zero ifTrue: [abs _ val negated] ifFalse: [abs _ val]. abs < "2**6" 64 ifTrue: [stream putByte: (val bitAnd: 127). ^VOID]. abs < "2**13" 8192 ifTrue: [stream putByte: (((val bitShiftRight: 8) bitAnd: 2r0111111) bitOr: 2r10000000). stream putByte: (val bitAnd: 255). ^VOID]. abs < "2**20" 1048576 ifTrue: [stream putByte: (((val bitShiftRight: 16) bitAnd: 2r011111) bitOr: 2r11000000). stream putByte: ((val bitShiftRight: 8) bitAnd: 255). stream putByte: (val bitAnd: 255). ^VOID]. abs < "2**27" 134217728 ifTrue: [stream putByte: (((val bitShiftRight: 24) bitAnd: 2r00001111) bitOr: 2r11100000). stream putByte: ((val bitShiftRight: 16) bitAnd: 255). stream putByte: ((val bitShiftRight: 8) bitAnd: 255). stream putByte: (val bitAnd: 255). ^VOID]. "abs < (2**34)" true ifTrue: [stream putByte: (((val bitShiftRight: 32) bitAnd: 2r0111) bitOr: 2r11110000). stream putByte: ((val bitShiftRight: 24) bitAnd: 255). stream putByte: ((val bitShiftRight: 16) bitAnd: 255). stream putByte: ((val bitShiftRight: 8) bitAnd: 255). stream putByte: (val bitAnd: 255). ^VOID]. Eric thingToDo. "humber case"! {void} sendNULL myStream putByte: Int0. self endThing! {void} startNewInstance: cat {Category} "start sending an instance of a particular class. Add one because 0 means NULL" myDepth _ myDepth + 1. self sendCategory: cat! {XnWriteStream INLINE} stream ^myStream! ! !Binary2Xmtr methodsFor: 'creation'! create: specialist {TransferSpecialist} with: stream {XnWriteStream} super create: specialist. myStream _ stream. myDepth _ IntegerVar0! {void} destroy (SomeXmtrs store: self) ifFalse: [super destroy]! ! !Binary2Xmtr methodsFor: 'specialist sending'! {void} endInstance "end sending an instance" myDepth _ myDepth - 1. self endThing! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Binary2Xmtr class instanceVariableNames: ''! (Binary2Xmtr getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !Binary2Xmtr class methodsFor: 'creation'! {SpecialistXmtr} make: specialist {TransferSpecialist} with: stream {XnWriteStream} | result {Heaper} | result := SomeXmtrs fetch. result == NULL ifTrue: [^ self create: specialist with: stream] ifFalse: [^ (self new.Become: result) create: specialist with: stream]! ! !Binary2Xmtr class methodsFor: 'smalltalk: init'! initTimeNonInherited SomeXmtrs := InstanceCache make: 8! linkTimeNonInherited MaxNumberLength _ 400. NumberBuffer _ UInt8 vector create: MaxNumberLength. [NumberBuffer _ UInt8Array make: MaxNumberLength] smalltalkOnly. SomeXmtrs := NULL! !SpecialistXmtr subclass: #TextyXmtr instanceVariableNames: ' myStream {XnWriteStream} myDepth {IntegerVar} myNeedsSep {BooleanVar}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Xcvr'! (TextyXmtr getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !TextyXmtr methodsFor: 'sending'! {void} sendBooleanVar: b {BooleanVar} self startThing. b ifTrue: [myStream putByte: $1 uint8] ifFalse: [myStream putByte: $0 uint8]. self endThing! {void} sendCategory: cat {Category} self startThing. [self sendIdentifier: cat name] translateOnly. [self sendIdentifier: (cat name copyUpTo: $.)] smalltalkOnly. self endThing! {void} sendIEEEDoubleVar: x {IEEEDoubleVar} "Sending the normal decimal approximation doesn't work because it introduces roundoff error. What we need to do instead is send a hex encoding of the IEEE double precision (64-bit) representation of the number. For clarity in the textual protocol, we also include the decimal approximation in a comment." self startThing. [myStream putStr: x printString] smalltalkOnly. ' char str[CONVERTSTRLEN]; sprintf(str, "%g", x); myStream->putStr(str);' translateOnly. self endThing! {void} sendInt32: n {Int32} self startThing. [myStream putStr: n printString] smalltalkOnly. ' char str[CONVERTSTRLEN]; sprintf(str, "%d", n); myStream->putStr(str);' translateOnly. self endThing! {void} sendInt8: n {Int8} self startThing. [myStream putStr: n printString] smalltalkOnly. ' char str[CONVERTSTRLEN]; sprintf(str, "%d", n); myStream->putStr(str);' translateOnly. self endThing! {void} sendIntegerVar: n {IntegerVar} self startThing. [myStream putStr: n printString] smalltalkOnly. '(&n)->sendSelfTo(this);' translateOnly. self endThing! {void} sendString: s {char star} self startThing. myStream putByte: $" uint8. [self hack. "not complete C string form" s do: [:c {char} | c == $' ifTrue: [myStream putStr: '\'''] ifFalse: [c == $" ifTrue: [myStream putStr: '\"'] ifFalse: [c == (Character cr) ifTrue: [myStream putStr: '\n'] ifFalse: [c == (Character tab) ifTrue: [myStream putStr: '\t'] ifFalse: [c == (Character backspace) ifTrue: [myStream putStr: '\b'] ifFalse: [(c isSeparator not or: [c == $ ]) ifTrue: [myStream putByte: c uint8] ifFalse: [self class blast.InvalidCharacter raise]]]]]]]] smalltalkOnly. 'for(; *s !!= ''\0''; s++) { switch (*s) { /*case ALERT_CHAR: myStream->putStr("\\a"); break;*/ case ''\n'': myStream->putStr("\\n\\\n"); break; case ''\t'': myStream->putStr("\\t"); break; case ''\b'': myStream->putStr("\\b"); break; case ''\r'': myStream->putStr("\\r"); break; case ''\f'': myStream->putStr("\\f"); break; case ''\v'': myStream->putStr("\\v"); break; case ''\\'': myStream->putStr("\\\\"); break; case ''\'''': myStream->putStr("\\\''"); break; case ''\"'': myStream->putStr("\\\""); break; default: if (isprint(*s)) { myStream->putByte(*s); } else { BLAST(NON_PRINTING_CHARACTER); } } }' translateOnly. myStream putByte: $" uint8. self endThing! {void} sendUInt32: n {UInt32} self startThing. [myStream putStr: n printString] smalltalkOnly. ' char str[CONVERTSTRLEN]; sprintf(str, "%u", n); myStream->putStr(str);' translateOnly. self endThing! {void} sendUInt8: n {UInt8} self startThing. [myStream putStr: n printString] smalltalkOnly. ' char str[CONVERTSTRLEN]; sprintf(str, "%u", n); myStream->putStr(str);' translateOnly. self endThing! {void} sendUInt8Data: array {UInt8Array} self startThing. myStream putByte: $" uint8. Int32Zero almostTo: array count do: [ :i {Int32} | myStream putByte: ((array uIntAt: i) basicCast: UInt8)]. myStream putByte: $" uint8. self endThing! ! !TextyXmtr methodsFor: 'specialist sending'! {void} endInstance "end sending an instance" myStream putByte: $) uint8. myDepth _ myDepth - 1. self endThing! ! !TextyXmtr methodsFor: 'protected: sending'! {void} decrementDepth myDepth _ myDepth - 1! {void} endPacket myStream putByte: $; uint8. myStream flush. myNeedsSep _ false. super endPacket! {void} endThing myDepth == IntegerVar0 ifTrue: [self endPacket] ifFalse: [myNeedsSep _ true]! {void} incrementDepth myDepth _ myDepth + 1! {void} putByte: b {UInt8} myStream putByte: b! {void} sendNULL self startThing. self sendIdentifier: 'NULL'. self endThing! {void} startNewInstance: cat {Category} "start sending an instance of a particular class" myDepth _ myDepth + 1. self sendCategory: cat. myStream putByte: $( uint8. myNeedsSep _ false! {void} startThing myNeedsSep ifTrue: [myStream putByte: $, uint8]. myNeedsSep _ false! ! !TextyXmtr methodsFor: 'private: sending'! {void} sendIdentifier: identifier {char star} "send an identifier" myStream putStr: identifier! ! !TextyXmtr methodsFor: 'creation'! create: specialist {TransferSpecialist} with: stream {XnWriteStream} super create: specialist. myStream _ stream. myDepth _ IntegerVar0. myNeedsSep _ false! ! !TextyXmtr methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '( ' << myStream << ')'! ! !TextyXmtr methodsFor: 'overloading junk'! {void} sendHeaper: object {Heaper} super sendHeaper: object! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TextyXmtr class instanceVariableNames: ''! (TextyXmtr getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !TextyXmtr class methodsFor: 'creation'! {SpecialistXmtr} make: specialist {TransferSpecialist} with: stream {XnWriteStream} ^self create: specialist with: stream! !Heaper subclass: #XnReadStream instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Xcvr'! (XnReadStream getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !XnReadStream methodsFor: 'accessing'! {UInt8} getByte self subclassResponsibility! {void} getBytes: buffer {void star} with: count {Int32} with: start {Int32 default: Int32Zero} "Pour data directly into a buffer." start almostTo: start + count do: [:i {Int32} | (buffer basicCast: Character star) at: i put: self getByte]! {void} putBack: c {UInt8} self subclassResponsibility! {void} refill self subclassResponsibility! ! !XnReadStream methodsFor: 'smalltalk: defaults'! {void} getBytes: buffer {void star} with: count {Int32} "Pour data directly into a buffer." self getBytes: buffer with: count with: Int32Zero! ! !XnReadStream methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! XnReadStream class instanceVariableNames: ''! (XnReadStream getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !XnReadStream class methodsFor: 'creation'! make: collection {UInt8Array} ^ReadArrayStream create: collection.! make: dataP {UInt8 star} with: start {Int32} with: count {Int32} ^ReadMemStream make: dataP with: start with: count! !XnReadStream subclass: #ReadArrayStream instanceVariableNames: ' myBuffer {UInt8Array} myIndex {Int32}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Urdi'! (ReadArrayStream getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; add: #NOT.A.TYPE; yourself)! !ReadArrayStream methodsFor: 'accessing'! {UInt8} getByte | result {UInt8} | result _ myBuffer uIntAt: myIndex. myIndex _ myIndex + 1. ^result! {void} putBack: b {UInt8} myIndex > UInt32Zero assert: 'Must have room'. myIndex := myIndex - 1. (myBuffer uIntAt: myIndex) == b assert: 'Must be same character'! {void} refill! ! !ReadArrayStream methodsFor: 'creation'! create: collection {UInt8Array} super create. myBuffer _ collection. myIndex := UInt32Zero! ! !ReadArrayStream methodsFor: 'smalltalk: streams'! {BooleanVar} atEnd ^myIndex >= myBuffer count! {UInt8} next | result {UInt8} | result _ myBuffer uIntAt: myIndex. myIndex _ myIndex + 1. [^Character char: result] smalltalkOnly. [^result] translateOnly.! {String} peekAhead ^String streamContents: [:strm | 0 to: (myBuffer count - myIndex min: 100) do: [:i | strm nextPut: (Character char: (myBuffer uIntAt: myIndex + i))]]! ! !ReadArrayStream methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '(' << myIndex << ', ' << (myBuffer count - myIndex) << ', "'. Int32Zero almostTo: myIndex do: [:i {Int32} | oo DOTput: ((myBuffer uIntAt: i) basicCast: Character)]. oo << '<-|->'. myIndex almostTo: myBuffer count do: [:j {Int32} | oo DOTput: ((myBuffer uIntAt: j) basicCast: Character)]. oo << '")'! ! !ReadArrayStream methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! !XnReadStream subclass: #ReadMemStream instanceVariableNames: ' myBuffer {UInt8 star} myIndex {Int32} myStart {Int32} myEnd {Int32}' classVariableNames: 'SomeStreams {InstanceCache} ' poolDictionaries: '' category: 'Xanadu-Urdi'! (ReadMemStream getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; add: #NOT.A.TYPE; yourself)! !ReadMemStream methodsFor: 'accessing'! {UInt8} getByte | result {UInt8} | myIndex < myEnd assert: 'Stay within stream'. [result _ myBuffer uIntAt: myIndex] smalltalkOnly. [result _ myBuffer at: myIndex] translateOnly. myIndex _ myIndex + 1. ^result! {void} putBack: b {UInt8} myIndex > myStart assert: 'Must have room'. myIndex _ myIndex - 1. [(myBuffer uIntAt: myIndex) == b assert: 'Must be same character'.] smalltalkOnly. [(myBuffer at: myIndex) == b assert: 'Must be same character'] translateOnly! {void} refill! ! !ReadMemStream methodsFor: 'creation'! create: collection {UInt8 star} with: index {Int32} with: count {Int32} super create. myBuffer _ collection. myIndex _ index. myStart _ index. myEnd _ index + count! {void} destroy (SomeStreams store: self) ifFalse: [super destroy]! ! !ReadMemStream methodsFor: 'smalltalk: streams'! {BooleanVar} atEnd ^myIndex >= myEnd! {UInt8} next | result {UInt8} | result _ myBuffer at: myIndex+1. myIndex _ myIndex + 1. [^Character char: result] smalltalkOnly. [^result] translateOnly.! {String} peekAhead ^String streamContents: [:strm | 0 to: (myEnd - myIndex min: 100) do: [:i | strm nextPut: (Character char: (myBuffer uIntAt: myIndex + i))]]! ! !ReadMemStream methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '(' << (myIndex - myStart) << ', ' << (myEnd - myIndex) << ', "'. myStart almostTo: myIndex do: [:i {Int32} | oo DOTput: ((myBuffer at: i) basicCast: Character)]. oo << '<-|->'. myIndex almostTo: myEnd do: [:j {Int32} | oo DOTput: ((myBuffer at: j) basicCast: Character)]. oo << '")'! ! !ReadMemStream methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ReadMemStream class instanceVariableNames: ''! (ReadMemStream getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; add: #NOT.A.TYPE; yourself)! !ReadMemStream class methodsFor: 'creation'! {XnReadStream} make: dataP {UInt8 star} with: start {Int32} with: count {Int32} | result {Heaper} | result := SomeStreams fetch. result == NULL ifTrue: [^self create: dataP with: start with: count] ifFalse: [^(self new.Become: result) create: dataP with: start with: count]! ! !ReadMemStream class methodsFor: 'smalltalk: init'! initTimeNonInherited SomeStreams := InstanceCache make: 8! linkTimeNonInherited SomeStreams := NULL! !XnReadStream subclass: #XnBufferedReadStream instanceVariableNames: ' myPortal {PacketPortal} myBuffer {UInt8Array} myNext {Int32} myMax {Int32}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Xcvr'! (XnBufferedReadStream getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; add: #NOT.A.TYPE; yourself)! !XnBufferedReadStream methodsFor: 'accessing'! {UInt8Array} contents myBuffer == NULL ifTrue: [^(PrimIntArray zeros: 8 with: Int32Zero) cast: UInt8Array]. ^(myBuffer copy: myMax - myNext with: myNext) cast: UInt8Array! {UInt8} getByte | result {UInt8} | [myNext >= myMax] whileTrue: [self refill]. result _ myBuffer uIntAt: myNext. myNext _ myNext + 1. ^result! {void} getBytes: buffer {void star} with: count {Int32} with: start {Int32 default: Int32Zero} "Pour data directly into a buffer." self thingToDo. "Make a more efficient version of this." start almostTo: start + count do: [:i {Int32} | (buffer basicCast: Character star) at: i put: self getByte]! {BooleanVar} isReady self refill. ^myNext < myMax! {void} putBack: c {UInt8} (myNext <= Int32Zero) ifTrue: [Heaper BLAST: #BeginningOfPacket]. (myBuffer uIntAt: myNext -1) ~= c ifTrue: [Heaper BLAST: #DoesNotMatch]. myNext _ myNext -1.! {void} refill (myNext < myMax) ifFalse: [myBuffer == NULL ifTrue: [myBuffer _ myPortal readBuffer]. myMax _ myPortal readPacket: myBuffer with: myBuffer count. myNext _ Int32Zero]! ! !XnBufferedReadStream methodsFor: 'creation'! create: portal {PacketPortal} super create. myPortal _ portal. myBuffer _ NULL. myNext _ Int32Zero. myMax _ myNext! ! !XnBufferedReadStream methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '(' << myNext << ', ' << myMax. myBuffer == NULL ifTrue: [oo << ')'. ^VOID]. oo << ', "'. Int32Zero almostTo: myNext do: [:i {Int32} | oo DOTput: ((myBuffer uIntAt: i) basicCast: Character)]. oo << '<-|->'. myNext almostTo: myMax do: [:j {Int32} | oo DOTput: ((myBuffer uIntAt: j) basicCast: Character)]. oo << '")'! ! !XnBufferedReadStream methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! !Heaper subclass: #XnRegion instanceVariableNames: '' classVariableNames: ' CantMixCoordSpacesSignal {Signal smalltalk} EmptyRegionSignal {Signal smalltalk} ' poolDictionaries: '' category: 'Xanadu-Spaces-Basic'! XnRegion comment: 'The design of a new coordinate space consists mostly in the design of the XuRegions which can be used to describe (possibly infinite) sets of positions in that coordinate space. It will generally not be the case (for a given coordinate space) that all mathematically describable sets of positions will be representable by an XuRegion in that space. This should not be seen as a temporary deficiency of the current implementation of a space, but rather part of the design of what a given space *means*. For example, in IntegerSpace, one cannot form the XuRegion whose members are exactly the even numbers. If this were possible, other desirable properties which are part of the intent of IntegerSpaces would no longer be possible. For example, any XuRegion should be able to break itself up into a finite number of simple XuRegions ("simple" is described below). Were an even number region possible, this would have undesirable consequences for the definition of "simple" in this space. If you want (for example) to be able to have a XuRegion which can represent all the even numbers, it probably makes more sense to define a whole new space in which these new XuRegions apply. XuRegions should be closed under a large set of operations, such as intersection, unionWith, complement and minus. ("closed" means that the result of performing this operation on XuRegions of a given space is another valid XuRegion in the same space.) Additional guarantees are documented with each operation. A XuRegion may be classified at one of three levels of "simplicity": 1) The simplest are the *distinctions*. Distinctions are those that answer with (at most) a single set containing themselves in response to the message "distinctions". (The reason I say "at most" is that a full region (one that covers the entire coordinate space) may answer with the empty set.) Distinctions are the simplest XuRegions of a given space out of which all other XuRegions of that space can be finitely composed. There should probably be a message "isDistinction" for which exactly the distinctions answer "true". The complement of a distinction is a distinction. Three examples of distinctions in spaces are: a) in IntegerSpace, any simple inequality. For example, all integers < 37. b) in one kind of 3-space, any half space (all the space on one side of some plane) c) in another kind of 3-space, any sphere or spherical hole. Note that "c" could not just have spheres as the distinction because distinctions must be closed under complement. (We are here ignoring the quite substantial problems that arise in dealing with approximate (e.g., floating point) which would almost necessarily have to arise in doing any decent 3-space. 3-space is nevertheless a good intuition pump.) 2) Next are the *simple regions*. Simple regions are exactly those that say "true" to "isSimple". All distinctions are also simple regions. In response to the message "distinctions", and simple region must return a finite set of distinctions which, when intersected together, yield the original simple region. Generally, one tries to define the simple regions for a space to correspond to some notion of locality in the space. For example, it may be good for a simple region not to be able to have a hole in it. Or perhaps a simple region is which must be connected (whatever that means in a given space). Example non-distinction simple regions for the above example spaces would be: a) The interval from 3 inclusive to 17 exclusive (intersection of all integers >= 3 and all < 17) b) A convex hull (intersection of half spaces) c) Whatever you get by intersecting a bunch of spheres and sherical holes. The simple regions for both "a" and "b" would be connected, without holes, and even convex. This follows directly from the definition of our distinctions. None of these nice properties holds for "c", and this also follows directly from our decision to start with spheres. "c" is still perfectly valid, just less preferable by some criteria. 3) Finally, there are the regions of a space in general. Any region must respond to the message "simpleRegions" with a stepper which will produce a finite number of simple regions that, when unioned together, yields the original region. A simple region will return a stepper that will return at most itself ("at most" because an empty region (which covers no positions) may return an empty stepper). Example non-simple regions are: a) all integers < 3 and all integers >= 17 b) two convex hulls c) two disjoint spheres Note that "a" is the complement of the earlier "a" example, thereby showing why the complement of a simple region isn`t necessarily simple. Even though the "c" space is so unconstrained in the properties of its simple regions, there is no way to interect a finite number of spheres and spherical holes to produce a pair of disjoint spheres. Therefore the pair is non-simple. Not all spaces must have non-simple regions (or even non-distinctions). It is interesting to observe for "b" and "c" that even though there is a natural conversion between their respective positions, (except for the empty and full regions) there is no conversion at all between their respective regions. The kinds of sets of positions representable in one space is completely different than those representable in the other space. We will use these three example spaces repeatedly in documenting the protocol.'! (XnRegion getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; yourself)! !XnRegion methodsFor: 'accessing'! {XnRegion} asSimpleRegion "Return a simple region containing all positions contained by myself. If I am simple, then the result must be me. Otherwise, the resulting region will contain more positions than I do, but it must contain all those that I do. It would be good for the resulting simple region to not contain many more points than it needs in order to satisfy these constraints; but this is a preference, not a specification. Particular spaces may specify stronger guarantees, but as far as class XuRegion is concerned it is correct (though silly) for this message to always return the full region for the space." ^self simpleUnion: self! {CoordinateSpace CLIENT} coordinateSpace "Essential. The coordinate space in which this is a region" self subclassResponsibility! ! !XnRegion methodsFor: 'operations'! {XnRegion CLIENT} complement "Essential. Return a region of containing exactly those positions not in this region. The complement of a distinction must be a distinction." self subclassResponsibility! {XnRegion} delta: region {XnRegion} "The region where they differ. a->delta(b) ->isEqual (a->minus(b)->unionWith(b->minus(a)))" ^(self minus: region) unionWith: (region minus: self)! {XnRegion CLIENT} intersect: other {XnRegion unused} "Essential. The intersection of two simple regions must be simple. The intersection of two distinctions must therefore be a simple region. The result has exactly those members which both the original regions have." self subclassResponsibility! {XnRegion CLIENT} minus: other {XnRegion} "The region containing all my position which aren't in other." other isEmpty ifTrue: [^self ] ifFalse: [ ^self intersect: other complement ]! {XnRegion} simpleUnion: other {XnRegion unused} "The result must contain all positions contained by either of the two original regions, and the result must be simple. However, the result may contain additional positions. See the comment on 'XuRegion::asSimpleRegion'. a->simpleUnion(b) satisfies the same specification as (a->unionWith(b))->asSimpleRegion(). However, the two results do not have to be the same region." self subclassResponsibility! {XnRegion CLIENT} unionWith: other {XnRegion unused} "The result has as members exactly those positions which are members of either of the original two regions. No matter how simple the two original regions are, the result may be non-simple. The only reason this is called 'unionWith' instead of 'union' is that the latter is a C++ keyword." self subclassResponsibility! {XnRegion CLIENT} with: pos {Position} "the region with one more position. Actually, if I already contain pos, then the result is just me." ^self unionWith: pos asRegion! {XnRegion CLIENT} without: pos {Position} "the region with one less position. Actually if I already don't contain pos, then the result is just me." ^self minus: pos asRegion! ! !XnRegion methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! {BooleanVar CLIENT} hasMember: atPos {Position unused} "Do I contain this position? More than anything else, the behavior of this message is the defining characteristic of an XuRegion. All other messages (except for the simplicity characterization) should be specifiable in terms of the behavior of this message. What an XuRegion *is* (mostly) is a finite decision procedure for accepting or rejecting any given position." self subclassResponsibility! {BooleanVar CLIENT} intersects: other {XnRegion} "Essential. tell whether it has any points in common" self isEmpty ifTrue: [ ^ false ] ifFalse: [other isEmpty ifTrue: [^ false] ifFalse: [^(self intersect: other) isEmpty not]]! {BooleanVar} isDistinction "Am I a distinction. See XuRegion class comment for implications of being a distinction." ^self isSimple and: [self distinctions count <= 1]! {BooleanVar CLIENT} isEmpty "Every coordinate space has exactly one empty region. It is the one containing no positions. It and only it responds 'true' to this message." self subclassResponsibility! {BooleanVar} isEqual: other {Heaper} "Two regions are equal iff they contain exactly the same set of positions" self subclassResponsibility! {BooleanVar CLIENT} isFinite "Essential. Do I contain a finite number of positions? If I do, then the 'count' message will say how many, and I will gladly provide a stepper which will step over all of them. I.e., isFinite implies isEnumerable." self subclassResponsibility! {BooleanVar CLIENT} isFull "true if this is the largest possible region in this space -- the region that contains all positions in the space. Note that in a space which has no positions (which is perfectly valid), the one XuRegion would be both empty (since it has no positions) and full (since it has all the positions in the space)." ^self complement isEmpty! {BooleanVar} isSimple "Am I a simple region. See XuRegion class comment for implications of being simple." self subclassResponsibility! {BooleanVar CLIENT} isSubsetOf: other {XnRegion} "I'm a subset of other if I don't have any positions that he doesn't. Note that if we are equal, then I am still a subset of him. If you want to know if I'm a strict subset, you can ask a->isSubsetOf(b) && !! a->isEqual(b)" ^(self minus: other) isEmpty! ! !XnRegion methodsFor: 'smalltalk: defaults'! {XnRegion CLIENT} chooseMany: n {IntegerVar} ^self chooseMany: n with: NULL! {Position CLIENT} chooseOne ^self chooseOne: NULL! disjointSimpleRegions "emulate default argument of NULL" ^self disjointSimpleRegions: NULL! {BooleanVar} isEnumerable "emulate default argument of NULL" ^self isEnumerable: NULL! {Mapping} mapping: data {PrimArray} ^self mapping: data with: NULL! simpleRegions "emulate default argument of NULL" ^self simpleRegions: NULL! {Stepper CLIENT of: Position} stepper "emulate default argument of NULL" ^self stepper: NULL! ! !XnRegion methodsFor: 'enumerating'! {XnRegion CLIENT} chooseMany: n {IntegerVar} with: order {OrderSpec default: NULL} "If an OrderSpec is given, return the first n elements according to that OrderSpec. If no OrderSpec is given, then iff I contain at least n positions, return n of them; otherwise BLAST. This should be implemented even by regions that aren't enumerable. Inspired by the axiom of choice." Someone shouldImplement. ^NULL "fodder"! {Position CLIENT} chooseOne: order {OrderSpec default: NULL} "Essential. If an OrderSpec is given, return the first element according to that OrderSpec. If no OrderSpec is given, then iff I contain at least one position, return one of them; otherwise BLAST. This should be implemented even by regions that aren't enumerable. Inspired by the axiom of choice." self isEmpty ifTrue: [Heaper BLAST: #EmptyRegion]. self thingToDo. "self isEnumerable assert: 'Must be overridden otherwise'." ^(self stepper: order) get cast: Position! {IntegerVar CLIENT} count "How many positions do I contain? If I am not 'isFinite', then this message will BLAST." self subclassResponsibility! {Stepper INLINE of: XnRegion} disjointSimpleRegions: order {OrderSpec default: NULL} "break it up into a set of non-empty simple regions which don't overlap. This message satisfies all the specs of 'simpleRegions', and in addition provides for lack of overlap. It may be significantly more expensive than 'simpleRegions' which is why they both exist." ^DisjointRegionStepper make: self with: order! {ScruSet of: XnRegion} distinctions "Break it up into a set of non-full distinctions. It is an error to send this to a non-simple region. A full region will respond with the null set. Other distinctions will respond with a singleton set containing themselves, and simple regions will respond with a set of distinctions which, when intersected together, yield the original region." self subclassResponsibility! {Stepper} simpleRegions: order {OrderSpec default: NULL} "Break myself up into a finite set of non-empty simple regions which, when unionWith'ed together will yield me. May be sent to any region. If I am isEmpty, I will respond with the empty stepper. Otherwise, if I am simple I will respond with a stepper producing just myself. Please only use NULL for the 'order' argument for now unless the documentation for a particular region or coordinate space says that it will deal with the 'order' argument meaningfully. When no order is specified then I may return the simple regions in any order. When the ordering functionality is implemented, then I am constrained to produce the simple regions in an order consistent with the argument's ordering of my positions. When the simple regions don't overlap, and don't surround each other in the ordering, then the meaning is clear. Otherwise, there are several plausible options for how we should specify this message." self subclassResponsibility! {Stepper CLIENT of: Position} stepper: order {OrderSpec default: NULL} "Essential. If my positions are enumerable in the order specified, then return a stepper which will so enumerate them. If 'order' is NULL, then I may treat this as a request to enumerate according to any order I choose, except that if I am enumerable in ascending order, then I must be enumerable given NULL. For example, if I choose to regard NULL as implying ascending order, and I am only enumerable in descending order, then given NULL, I may blast even though there is an order in which I am enumerable. In fact, right now the ability to respond to an 'order' argument is in such a to-be-implemented state that it should only be considered safe to provide a NULL argument, unless the documentation on a particular space or region says otherwise. The eventual specification of this message is clear, and is upwards compatible from the current behavior: If I can enumerate in an order consistent with 'order', do so. If 'order' is NULL, then if I can be enumerated at all (if there is any counting sequence), then I still do so. For example, I should be able to get an (infinite) stepper for stepping through all the integers, but not all the reals. As the above example shows, being enumerable doesn't imply being finite. Also, being able to produce a stepper that continues to yield more positions in the specified order is not sufficient to imply being enumerable. To be enumerable, it must be the case that any given position which is a member of the region will eventually be reached by the stepper. Not all implementations currently succeed in guaranteeing this (See UnionCrossRegion::isEnumerable). See ScruTable::stepper." | ord {OrderSpec | NULL} | ord := order. ord == NULL ifTrue: [ord := self coordinateSpace fetchAscending]. ord == NULL ifTrue: [Heaper BLAST: #NotEnumerable]. ^self actualStepper: ord! {Position CLIENT} theOne "Iff I contain exactly one position, return it. Otherwise BLAST. The idea for this message is taken from the THE function of ONTIC (reference McAllester)" | stepper {Stepper} result {Position} | (self isFinite and: [self count == 1]) ifFalse: [ Heaper BLAST: #NotOneElement ]. stepper _ self stepper. result _ stepper fetch cast: Position. stepper destroy. ^ result! ! !XnRegion methodsFor: 'smalltalk: special'! {void} do: aBlock {BlockClosure of: Position} self stepper forEach: aBlock! ! !XnRegion methodsFor: 'protected: enumerating'! {Stepper of: Position} actualStepper: order {OrderSpec} "Only called if I've already said I'm enumerable in the originally stated order. Also, if the originally stated order was NULL, I get a guaranteed non-null order. Subclasses which override 'stepper' to a method which doesn't send 'actualStepper' may override 'actualStepper' to a stub method which always BLASTs." self subclassResponsibility! ! !XnRegion methodsFor: 'smalltalk: passe'! {PtrArray of: Position} asArray: order {OrderSpec default: NULL} "Returns all the Positions in the region in order according to 'order'. If the region isn't finite, then this BLASTs." self passe "| result {PtrArray of: Position} i {Int32} | self isFinite not ifTrue: [Heaper BLAST: #NotFinite]. result := PtrArray make: self count DOTasLong. i := Int32Zero. (self stepper: order) forEach: [:pos {Position} | result at: i store: pos. i := i + 1]. (self count == i) assert: 'My stepper must yield same count of positions that I report'. ^result"! {BooleanVar} isEnumerable: order {OrderSpec default: NULL} "See comment in XuRegion::stepper. a->stepper(os) won't BLAST iff a->isEnumerable(os)" self subclassResponsibility! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! XnRegion class instanceVariableNames: ''! (XnRegion getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; yourself)! !XnRegion class methodsFor: 'pseudo constructors'! {ImmuSet} immuSet.make: region {XnRegion} "Make a set containing all the positions in the region" region isFinite ifFalse: [Heaper BLAST: #MustBeFinite]. ^(MuSet fromStepper: region stepper) asImmuSet! ! !XnRegion class methodsFor: 'smalltalk: system'! info.stProtocol "{Position CLIENT} chooseOne: order {OrderSpec default: NULL} {XuRegion CLIENT} complement {CoordinateSpace CLIENT} coordinateSpace {IntegerVar CLIENT} count {BooleanVar CLIENT} hasMember: atPos {Position unused} {XuRegion CLIENT} intersect: other {XuRegion unused} {BooleanVar CLIENT} intersects: other {XuRegion} {BooleanVar CLIENT} isEmpty {BooleanVar CLIENT} isFinite {BooleanVar CLIENT} isFull {BooleanVar CLIENT} isSubsetOf: other {XuRegion} {XuRegion CLIENT} minus: other {XuRegion} {Stepper CLIENT of: Position} stepper: order {OrderSpec default: NULL} {Position CLIENT} theOne {XuRegion CLIENT} unionWith: other {XuRegion unused} {XuRegion CLIENT} with: pos {Position} {XuRegion CLIENT} without: pos {Position} "! !XnRegion subclass: #CrossRegion instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Spaces-Cross'! CrossRegion comment: 'A cross region is a distinction if 1) it is empty, 2) it is full, or 3) it is the rectangular cross of full regions and one distinction. Note that case 3 actually subsumes 1 and 2. Since the simple regions of a space are the intersections of a finite number of distinctions of a space, this implies that A cross region is simple if it is the rectangular cross of simple regions. In other words, a simple region is identical to the cross of its projections.'! (CrossRegion getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; yourself)! !CrossRegion methodsFor: 'testing'! {UInt32} actualHashForEqual "To avoid overly burdensome canonicalization rules, my hash is calculated from the hash of my projections" ^#cat.U.CrossRegion hashForEqual bitXor: self projections contentsHash.! {BooleanVar} hasMember: atPos {Position unused} self subclassResponsibility! {BooleanVar} isEmpty self subclassResponsibility! {BooleanVar} isEnumerable: order {OrderSpec unused default: NULL} self subclassResponsibility! {BooleanVar} isEqual: other {Heaper} self subclassResponsibility! {BooleanVar} isFinite self subclassResponsibility! {BooleanVar} isSimple self subclassResponsibility! ! !CrossRegion methodsFor: 'enumerating'! {Stepper CLIENT of: CrossRegion} boxes "Essential. Divide this Region up into a disjoint sequence of boxes. A box is a region which is the cross of its projections." self subclassResponsibility! {IntegerVar} count self subclassResponsibility! {ScruSet of: XnRegion} distinctions self subclassResponsibility! {BooleanVar CLIENT} isBox "Whether this Region is a box, i.e. is equal to the cross of its projections." self subclassResponsibility! {Stepper} simpleRegions: order {OrderSpec default: NULL} self subclassResponsibility! ! !CrossRegion methodsFor: 'operations'! {XnRegion} asSimpleRegion self subclassResponsibility! {XnRegion} complement self subclassResponsibility! {XnRegion} intersect: other {XnRegion unused} self subclassResponsibility! {XnRegion} simpleUnion: other {XnRegion} ^(self unionWith: other) asSimpleRegion! {XnRegion} unionWith: other {XnRegion unused} self subclassResponsibility! ! !CrossRegion methodsFor: 'accessing'! {CoordinateSpace} coordinateSpace self subclassResponsibility! {XnRegion CLIENT} projection: index {Int32} "The answer is the projection of this region into the specified dimension of the cross space" ^(self projections fetch: index) cast: XnRegion! {PtrArray CLIENT of: XnRegion} projections "Essential. The answer is the projection of this region into each dimension of the cross space. Note that two regions which are different can have the same projections." self subclassResponsibility! ! !CrossRegion methodsFor: 'protected: enumerating'! {Stepper of: Position} actualStepper: order {OrderSpec} self subclassResponsibility! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CrossRegion class instanceVariableNames: ''! (CrossRegion getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; yourself)! !CrossRegion class methodsFor: 'smalltalk: system'! info.stProtocol "{Stepper CLIENT of: CrossRegion} boxes {BooleanVar CLIENT} isBox {XuRegion CLIENT} projection: index {Int32} {PtrArray CLIENT of: XuRegion} projections "! !CrossRegion subclass: #GenericCrossRegion instanceVariableNames: ' mySpace {CrossSpace} myCount {Int32} myRegions {PtrArray of: XnRegion}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Spaces-Cross'! GenericCrossRegion comment: 'Represents a region as a two-dimensional array of crosses of subregions. Was NOT.A.TYPE but that obstructed compilation. I think this might work better if the array is lexically sorted, but I am not sure there is any meaningful way to do so. Thus there is no sorting assumed in the algorithms, although the protocol may occasionally suggest that there might be. Eventually this implementation may save space by using NULL to represent repetitions of a sub region such that fetchBoxProjection (box, dim) == NULL only if box > 0 && boxProjection (box, dim)->isEqual (boxProjection (box - 1, dim)) && (dim == 0 || fetchBoxProjection (box, dim - 1) == NULL)'! (GenericCrossRegion getOrMakeCxxClassDescription) friends: 'friend class BoxAccumulator; friend class BoxProjectionStepper; friend class BoxStepper; friend class GenericCrossDsp; friend class GenericCrossSpace; friend class CrossOrderSpec; '; attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !GenericCrossRegion methodsFor: 'accessing'! {CoordinateSpace} coordinateSpace ^mySpace! {IntegerVar} count | result {IntegerVar} boxes {BoxStepper} | result := IntegerVarZero. boxes := self boxStepper. [boxes hasValue] whileTrue: [ | sub {IntegerVar} | sub := 1. boxes projectionStepper forEach: [ :proj {XnRegion} | sub := sub * proj count]. result := result + sub. boxes step]. boxes destroy. ^result! {XnRegion} projection: index {Int32} | result {XnRegion} boxes {BoxStepper} | myCount = 1 ifTrue: [^self boxProjection: Int32Zero with: index]. result := (mySpace axis: index) emptyRegion. boxes := self boxStepper. [boxes hasValue] whileTrue: [result := result unionWith: (boxes projection: index). boxes step]. boxes destroy. ^result! {PtrArray of: XnRegion} projections | result {PtrArray of: XnRegion} boxes {BoxStepper} | result := PtrArray nulls: mySpace axisCount. UInt32Zero almostTo: result count do: [ :i {UInt32} | result at: i store: (mySpace axis: i) emptyRegion]. boxes := self boxStepper. [boxes hasValue] whileTrue: [boxes unionBoxInto: result with: Int32Zero. boxes step]. boxes destroy. ^result! {Position} theOne | result {PtrArray of: Position} | myCount = 1 ifFalse: [Heaper BLAST: #MustHaveSingleElement]. result := PtrArray nulls: mySpace axisCount. Int32Zero almostTo: result count do: [ :i {Int32} | result at: i store: (self boxProjection: Int32Zero with: i) theOne]. ^mySpace crossOfPositions: result! ! !GenericCrossRegion methodsFor: 'protected:'! {CrossSpace} crossSpace ^mySpace! ! !GenericCrossRegion methodsFor: 'private:'! {Int32} boxCount ^myCount! {XnRegion} boxProjection: box {Int32} with: dimension {Int32} "A region is at a given 2D place in the array" ^(myRegions fetch: box * self crossSpace axisCount + dimension) cast: XnRegion! {BoxProjectionStepper} boxProjectionStepper "A stepper over all projections of all boxes in the region" ^BoxProjectionStepper make: self! {BoxStepper} boxStepper "A stepper over all boxes" ^BoxStepper make: self! {BooleanVar} hasBoxProjection: other {XnRegion} with: box {Int32} with: dimension {Int32} "Whether a region is at a given 2D place in the array. Searches forward and backward through adjacent boxes which have the same hash value" | index {Int32} hash {UInt32} sub {XnRegion} | index := box. hash := other hashForEqual. [index >= Int32Zero and: [(sub := self boxProjection: index with: dimension) hashForEqual = hash]] whileTrue: [(sub isEqual: other) ifTrue: [^true]. index := index - 1]. index := box + 1. [index < myCount and: [(sub := self boxProjection: index with: dimension) hashForEqual = hash]] whileTrue: [(sub isEqual: other) ifTrue: [^true]. index := index + 1]. ^false! {PtrArray of: XnRegion} secretRegions "The array holding the regions. DO NOT MODIFY" ^myRegions! ! !GenericCrossRegion methodsFor: 'testing'! {UInt32} actualHashForEqual | result {UInt32} boxes {BoxStepper} | result := self getCategory hashForEqual. boxes := self boxStepper. [boxes hasValue] whileTrue: [result := result bitXor: boxes boxHash. boxes step]. boxes destroy. ^result! {BooleanVar} hasMember: position {Position} | boxes {BoxStepper} | boxes := self boxStepper. [boxes hasValue] whileTrue: [(boxes boxHasMember: (position cast: ActualTuple)) ifTrue: [^true]. boxes step]. ^false! {BooleanVar} intersects: other {XnRegion} | mine {BoxStepper} others {BoxStepper} | mine := self boxStepper. [mine hasValue] whileTrue: [others := (other cast: GenericCrossRegion) boxStepper. [others hasValue] whileTrue: [(mine boxIntersects: others) ifTrue: [^true]. others step]. mine step]. mine destroy. others destroy. ^false! {BooleanVar} isDistinction myCount > 1 ifTrue: [^false]. myCount == Int32Zero ifTrue: [^true]. self boxProjectionStepper forEach: [ :proj {XnRegion} | proj isDistinction ifFalse: [^false]]. ^true! {BooleanVar} isEmpty ^myCount == Int32Zero! {BooleanVar} isEnumerable: order {OrderSpec unused default: NULL} Someone shouldImplement. ^false "fodder"! {BooleanVar} isEqual: other {Heaper} other cast: GenericCrossRegion into: [ :cross | | boxes {BoxStepper} | (cross boxCount = myCount and: [cross crossSpace isEqual: self crossSpace]) ifFalse: [^false]. boxes := self boxStepper. [boxes hasValue] whileTrue: [(boxes isBoxOf: cross) ifFalse: [^false]. boxes step]. boxes destroy. ^true] others: [^false]. ^ false "compiler fodder"! {BooleanVar} isFinite self boxProjectionStepper forEach: [ :sub {XnRegion} | sub isFinite ifFalse: [^false]]. ^true! {BooleanVar} isFull myCount = 1 ifFalse: [^false]. self boxProjectionStepper forEach: [ :sub {XnRegion} | sub isFull ifFalse: [^false]]. ^true! {BooleanVar} isSimple myCount > 1 ifTrue: [^false]. myCount == Int32Zero ifTrue: [^true]. self boxProjectionStepper forEach: [ :proj {XnRegion} | proj isSimple ifFalse: [^false]]. ^true! {BooleanVar} isSubsetOf: other {XnRegion} Ravi thingToDo. "figure out a more efficient algorithm - the one commented out below doesn't work" ^super isSubsetOf: other "| others {BoxStepper} mine {BoxStepper} | others := other boxStepper. [others hasValue] whileTrue: [mine := self boxStepper. [mine hasValue] whileTrue: [(others boxIsSubsetOf: mine) ifFalse: [^false]. mine step]. others step]. ^true"! ! !GenericCrossRegion methodsFor: 'operations'! {XnRegion} asSimpleRegion | result {PtrArray} projections {BoxProjectionStepper} | self isEmpty ifTrue: [^self]. result := PtrArray nulls: mySpace axisCount. projections := self boxProjectionStepper. [projections hasValue] whileTrue: [(result fetch: projections dimension) == NULL ifTrue: [result at: projections dimension store: projections projection asSimpleRegion] ifFalse: [result at: projections dimension store: (((result fetch: projections dimension) cast: XnRegion) simpleUnion: projections projection)]. projections step]. projections destroy. ^mySpace crossOfRegions: result! {XnRegion} complement | result {XnRegion} boxes {BoxStepper} | self isEmpty ifTrue: [^mySpace fullRegion]. boxes := self boxStepper. result := boxes boxComplement. boxes step. [boxes hasValue] whileTrue: [result := result intersect: boxes boxComplement. boxes step]. boxes destroy. ^result! {XnRegion} intersect: region {XnRegion} region cast: GenericCrossRegion into: [ :other | | result {BoxAccumulator} smaller {GenericCrossRegion} larger {GenericCrossRegion} bits {BoxStepper} piece {BoxAccumulator} | self boxCount < other boxCount ifTrue: [smaller := self. larger := other] ifFalse: [smaller := other. larger := self]. smaller isEmpty ifTrue: [^smaller]. bits := smaller boxStepper. result := NULL. piece := BoxAccumulator make: larger. [bits hasValue] whileTrue: [piece intersectWithBox: bits. result == NULL ifTrue: [result := piece] ifFalse: [result addAccumulatedBoxes: piece]. bits step. bits hasValue ifTrue: [piece := BoxAccumulator make: larger]]. bits destroy. result mergeBoxes. result removeDeleted. ^result region]. ^ NULL "compiler fodder"! {XnRegion} unionWith: region {XnRegion} | result {BoxAccumulator} | region cast: GenericCrossRegion into: [ :other | | stepper {BoxStepper} | result := BoxAccumulator make: self. stepper := other boxStepper. result unionWithBoxes: stepper. stepper destroy. result mergeBoxes. result removeDeleted. ^result region]. ^ NULL "compiler fodder"! ! !GenericCrossRegion methodsFor: 'printing'! {void} printOn: oo {ostream reference} | boxes {BoxStepper} between {char star} | oo << '{'. boxes := self boxStepper. [boxes hasValue] whileTrue: [between := ''. boxes projectionStepper forEach: [ :proj {XnRegion} | oo << between. proj isFull ifTrue: [oo << '*'] ifFalse: [oo << proj]. between := ' x ']. boxes step. boxes hasValue ifTrue: [oo << ', ']]. boxes destroy. oo << '}'! ! !GenericCrossRegion methodsFor: 'enumerating'! {Stepper of: CrossRegion} boxes ^self boxStepper! {ScruSet of: XnRegion} distinctions | result {Accumulator} ps {BoxProjectionStepper} | self isSimple ifFalse: [Heaper BLAST: #MustBeSimple]. result := SetAccumulator make. ps := self boxProjectionStepper. ps forEach: [ :sub {XnRegion} | sub distinctions stepper forEach: [ :dist {XnRegion} | result step: (mySpace extrusion: ps dimension with: dist)]]. ^result value cast: ScruSet! {BooleanVar} isBox ^self isSimple! {Stepper} simpleRegions: order {OrderSpec default: NULL} order ~~ NULL ifTrue: [self unimplemented]. ^GenericCrossSimpleRegionStepper make: mySpace with: self boxStepper! ! !GenericCrossRegion methodsFor: 'protected: enumerating'! {Stepper of: Position} actualStepper: order {OrderSpec unused} self isEmpty ifTrue: [^Stepper emptyStepper]. Ravi thingToDo. "do a real stepper" self hack. ^Stepper itemStepper: self theOne! ! !GenericCrossRegion methodsFor: 'protected: create'! create: space {CrossSpace} with: count {Int32} with: regions {PtrArray of: XnRegion} super create. mySpace := space. myCount := count. myRegions := regions.! ! !GenericCrossRegion methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. mySpace _ receiver receiveHeaper. myCount _ receiver receiveInt32. myRegions _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: mySpace. xmtr sendInt32: myCount. xmtr sendHeaper: myRegions.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GenericCrossRegion class instanceVariableNames: ''! (GenericCrossRegion getOrMakeCxxClassDescription) friends: 'friend class BoxAccumulator; friend class BoxProjectionStepper; friend class BoxStepper; friend class GenericCrossDsp; friend class GenericCrossSpace; friend class CrossOrderSpec; '; attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !GenericCrossRegion class methodsFor: 'private: pseudo constructors'! {CrossRegion} empty: space {GenericCrossSpace} ^self create: space with: Int32Zero with: PtrArray empty! {CrossRegion} full: 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: XnRegion} | result := PtrArray nulls: subSpaces count. Int32Zero almostTo: result count do: [ :dimension {Int32} | result at: dimension store: ((subSpaces fetch: dimension) cast: CoordinateSpace) fullRegion]. ^self create: space with: 1 with: result! ! !GenericCrossRegion class methodsFor: 'create'! make: space {CrossSpace} with: count {Int32} with: regions {PtrArray of: XnRegion} ^ self create: space with: count with: regions! !XnRegion subclass: #Filter instanceVariableNames: 'myCS {FilterSpace}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Filter'! Filter comment: 'A position in a FilterSpace is a region in the baseSpace, and a filter is a set of regions in the baseSpace. It is often more useful to think of a Filter as a Boolean function whose input is a region in the baseSpace, and of unions, intersections, and complements of filters as ORs, ANDs, and NOTs of functions. Not all possible such functions can be represented as Filters, since there is an uncountable infinity of them for any non-finite CoordinateSpace. There are representations for some basic filters, and any filters resulting from a finite sequence of unions, intersections, and complements among them. The basic filters are: subsetFilter(cs,R) -- all subsets of R (i.e. all R1 such that R1->isSubsetOf(R)) supersetFilter(cs,R) -- all supersets of R (i.e. all R1 such that R->isSubsetOf(R1)) Mathematically, this is all that is necessary, since other useful filters like intersection filters can be generated from these. (e.g. intersectionFilter(R) is subsetFilter(R->complement())->complement()). However, there are several more pseudo constructors provided as shortcuts, including intersectionFilters, closedFilters, emptyFilters, and intersections and unions of sets of filters.'! (Filter getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; add: #COPY; yourself)! !Filter methodsFor: 'operations'! {XnRegion} complement self subclassResponsibility! {XnRegion} intersect: other {XnRegion} | result {XnRegion} | result := self fetchIntersect: other. result ~~ NULL ifTrue: [^result]. ^self complexIntersect: other! {XnRegion INLINE} simpleUnion: other {XnRegion} ^sel