"NOTE: Contains forward references to IdentitySet and ExtensibleArray." "Utility methods for bootstrapping that rely solely on primitives:" s@(String traits) at: i [ bootstrapCharacters at: (s byteAt: i) ]. s@(String traits) at: i put: c [ s byteAt: i put: c code ]. block@(CompiledMethod traits) do [ block applyTo: {} ]. cond@(CompiledMethod traits) whileFalse: body [ [ cond do ifTrue: [^ Nil]. body do ] loop ]. cond@(CompiledMethod traits) whileTrue: body [ [ cond do ifFalse: [^ Nil]. body do ] loop ]. array@(Array traits) do: block [| i size | i: 0. size: array size. [i = size] whileFalse: [block applyTo: {array at: i}. i: i + 1] ]. array@(Array traits) doWithIndex: block [| i size | i: 0. size: array size. [i = size] whileFalse: [block applyTo: {array at: i. i}. i: i + 1] ]. array@(Array traits) includes: obj [ array do: [| :each | each = obj ifTrue: [^ True]]. False ]. array@(Array traits) copyWith: obj [| newA | newA: (array newSize: array size + 1). array doWithIndex: [| :each :index | newA at: index put: each]. newA at: array size put: obj. newA ]. s@(Symbol traits) name [| i name size | name: (String newSize: s size). i: 0. size: s size. [i = size] whileFalse: [name at: i put: (s at: i). i: i + 1]. name ]. s@(Symbol traits) newNamed: name [| newS i size | newS: (s newSize: name size). i: 0. size: name size. [i = size] whileFalse: [newS at: i put: (name at: i). i: i + 1]. newS ]. _@lobby intern: s@(String traits) [| i size sym | size: s size. bootstrapSymbols do: [| :sym | sym size = size ifTrue: [i: 0. [(sym at: i) = (s at: i)] whileTrue: [i: i + 1. i = size ifTrue: [^ sym]]]]. sym: (Symbol newNamed: s). bootstrapSymbols: (bootstrapSymbols copyWith: sym). sym ]. "Core object functionality." x@(Root traits) = y@(Root traits) "Object equality; this should generally be overridden for each type that has some value semantics in its slots. When overriding this, also override the hash method for the kind of object, since hashing and equality testing are bound together for many container types." "The default equality is object identity." [x == y]. x@(Root traits) ~== y@(Root traits) "Whether the objects are not identical." [(x == y) not]. x@(Root traits) ~= y@(Root traits) "Whether the objects are not equal." [(x = y) not]. x@(Root traits) hash "The default hash value is the identity-based hash." [x identityHash]. x@(Root traits) shallowCopy "A cloning is a shallow copy. This is a Smalltalk idiom and may not be necessary for Slate, or may not be worth overriding." [x clone]. x@(Root traits) copy "Copy should return a new object which is = to the argument. The default is to return a clone. This should be overridden based on ='s overrides." [x shallowCopy]. x@(Root traits) hasSlotNamed: slotName "Whether there is a slot defined with the given Symbol name on the object." [ x slotNames includes: slotName ]. x@(Root traits) hasDelegateNamed: slotName "Whether there is a slot defined with the given Symbol name on the object." [ x delegateNames includes: slotName ]. x@(Root traits) accessorNameFor: slotName [ slotName ]. x@(Root traits) mutatorNameFor: slotName [| mutatorName nameString index | nameString: slotName name. mutatorName: (nameString newSize: nameString size + 1). index: 0. [index = nameString size] whileFalse: [mutatorName at: index put: (nameString at: index). index: index + 1]. mutatorName at: index put: $:. intern: mutatorName ]. x@(Root traits) defaultSlotValue "The default value for new slots for this object." [Nil]. x@(Root traits) addAccessorFor: slotName [ [| :obj | obj atSlotNamed: slotName] asAccessor: (x accessorNameFor: slotName) for: slotName on: {x} ]. x@(Root traits) addMutatorFor: slotName [ [| :obj :val | obj atSlotNamed: slotName put: val] asAccessor: (x mutatorNameFor: slotName) for: slotName on: {x. NoRole} ]. x@(Root traits) rawAddSlot: slotName valued: slotValue [| newObj | newObj: (#cloneWithSlot:valued: sendTo: {x. slotName. slotValue} through: {Root. slotName. slotValue}). #forwardTo: sendTo: {x. newObj} through: {Root. Root} ]. x@(Root traits) rawAddDelegate: slotName valued: slotValue [| newObj | newObj: (#cloneWithDelegate:valued: sendTo: {x. slotName. slotValue} through: {Root. slotName. slotValue}). #forwardTo: sendTo: {x. newObj} through: {Root. Root} ]. x@(Root traits) addImmutableSlot: slotName valued: slotValue [| newObj | (x hasSlotNamed: slotName) ifTrue: [x atSlotNamed: slotName put: slotValue. ^ x]. newObj: (x cloneWithSlot: slotName valued: slotValue). newObj addAccessorFor: slotName. x forwardTo: newObj ]. x@(Root traits) addSlot: slotName valued: slotValue [| newObj | newObj: (x addImmutableSlot: slotName valued: slotValue). newObj addMutatorFor: slotName. newObj ]. x@(Root traits) addSlot: slotName "Adds a slot with default value." [x addSlot: slotName valued: x defaultSlotValue]. x@(Root traits) addImmutableDelegate: slotName valued: slotValue [| newObj | (x hasDelegateNamed: slotName) ifTrue: [x atSlotNamed: slotName put: slotValue. ^ x]. newObj: (x cloneWithDelegate: slotName valued: slotValue). newObj addAccessorFor: slotName. x forwardTo: newObj ]. x@(Root traits) addDelegate: slotName valued: slotValue [| newObj | newObj: (x addImmutableDelegate: slotName valued: slotValue). newObj addMutatorFor: slotName. newObj ]. x@(Root traits) removeSlot: _@#traits [| newObj | ((x accessorNameFor: #traits) findOn: {x}) ifNotNilDo: [| :accessor | accessor removeFrom: {x}]. ((x mutatorNameFor: #traits) findOn: {x. NoRole}) ifNotNilDo: [| :mutator | mutator removeFrom: {x. NoRole}]. newObj: (x cloneWithoutSlot: #traits). #forwardTo: sendTo: {x. newObj} through: {Root. Root} ]. x@(Root traits) removeSlot: slotName [| newObj | ((x accessorNameFor: slotName) findOn: {x}) ifNotNilDo: [| :accessor | accessor removeFrom: {x}]. ((x mutatorNameFor: slotName) findOn: {x. NoRole}) ifNotNilDo: [| :mutator | mutator removeFrom: {x. NoRole}]. newObj: (x cloneWithoutSlot: slotName). x forwardTo: newObj ]. x@(Root traits) defaultDelegate "The default to delegate to; this should really not be used often." [Nil]. x@(Root traits) addDelegate: slotName "Adds a delegate slot with default value." [x addDelegate: slotName valued: x defaultDelegate]. x@(Root traits) addSlots: col "Adds slots for all the names in the collection." [ col do: [| :slotName | x addSlot: slotName]. x ]. x@(Root traits) addSlotsFrom: another "Adds all slots from the other object to the first, with their values." "TODO: ensure it adds the accessor methods." "TODO: ensure that slot properties are carried over" [ another slotNames do: [| :slotName | (x hasSlotNamed: slotName) ifFalse: [x addSlotNamed: slotName from: another]]. x ]. x@(Root traits) addSlotNamed: slotName from: another [ (another hasDelegateNamed: slotName) ifTrue: [x addDelegate: slotName valued: (another atSlotNamed: slotName)] ifFalse: [x addSlot: slotName valued: (another atSlotNamed: slotName)] ]. x@(Root traits) addSlotsNamed: slotNames from: another "Add the slots with the given names from the other object to the first, with their values." "TODO: ensure that slot properties are carried over" [| otherSlotNames | otherSlotNames: another slotNames. slotNames do: [| :slotName | (anotherSlotNames includes: slotName) ifTrue: [x addSlotNamed: slotName from: another]]. x ]. x@(Root traits) moveSlotNamed: slotName to: another "Adds the slot with the given name to the other object from the first, removing it then from the first." [ (x hasSlotNamed: slotName) ifFalse: [x slotNotFoundNamed: slotName]. another addSlotNamed: slotName from: x. ]. x@(Root traits) renameSlot: slotName to: newName "Replaces the slot with a slot having the new name and the same value." [| slotValue | (x hasSlotNamed: slotName) ifFalse: [x slotNotFoundNamed: slotName]. slotValue: (x atSlotNamed: slotName). x removeSlot: slotName. x addSlot: newName valued: slotValue ]. x@(Root traits) ensureSlot: slotName is: newValue unlessSatisfies: testBlock "Adds a slot of the given name to the object if one isn't present already, initializing the new slot to the value. If a slot with that name is present already, test the existing one via the comparison block, and only update the slot if it fails. This always returns the resulting value of the slot." [ (x hasSlotNamed: slotName) ifTrue: [| oldValue | oldValue: (x atSlotNamed: slotName). (testBlock applyWith: oldValue) ifTrue: [oldValue] ifFalse: [x atSlotNamed: slotName put: newValue. newValue]] ifFalse: [x addSlot: slotName valued: newValue. newValue] ]. x@(Root traits) ensureSlot: slotName is: newValue "Adds a slot of the given name to the object if one isn't present already, initializing the new slot to the value. If a slot with that name is present already, compare the newValue with the existing one via =, and only update the slot if they're not equal. This always returns the resulting value of the slot." [ x ensureSlot: slotName is: newValue unlessSatisfies: [| :old | old = newValue] ]. x@(Root traits) slotValuesDo: block "Apply the code to all the objects stored in the given one's slots." [ x slotNames do: [| :slotName | block applyWith: (x atSlotNamed: slotName)] ]. x@(Root traits) slotValues [x slotNames collect: [| :slotName | x atSlotNamed: slotName]]. x@(Root traits) delegatesDo: block "Apply the code to all the immediately delegated objects." [ x delegateNames do: [| :slotName | block applyWith: (x atSlotNamed: slotName)] ]. x@(Root traits) nonDelegatesDo: block "Apply the code to all the objects stored in slots but not delegated-to by the object." [| delegateSymbols | delegateSymbols: x delegateNames. x slotNames do: [| :slotName | (delegateSymbols includes: slotName) ifFalse: [block applyWith: (x atSlotNamed: slotName)]]. x ]. x@(Root traits) delegateValues [x delegateNames collect: [| :slotName | x atSlotNamed: slotName]]. x@(Root traits) allDelegates "Recurse through the delegation chains, collecting all delegates." [| seen | seen: IdentitySet newEmpty. x allDelegatesWithSeen: seen. seen ]. x@(Root traits) allDelegatesWithSeen: seen "Recurse through the delegation chains, maintaining the set of visited objects." [ x delegatesDo: [| :delegate | (seen includes: delegate) ifFalse: [seen include: delegate. delegate allDelegatesWithSeen: seen]] ]. x@(Root traits) allDelegatesDo: block "Recurse through the delegation chains, avoiding repeated visits." [| seen | seen: IdentitySet newEmpty. x allDelegatesDo: block withSeen: seen ]. x@(Root traits) allDelegatesDo: block withSeen: seen "Recurse through the delegation chains. seen, should be an empty Set to avoid circularity." [ x delegatesDo: [| :each | (seen includes: each) ifFalse: [seen include: each. block applyWith: each. each allDelegatesDo: block withSeen: seen]]. Nil ]. x@(Root traits) isSameAs: y@(Root traits) "Answer whether the two objects have the exact same shared behavior." [x traits == y traits]. x@(Root traits) commonTraitsWith: y@(Root traits) "Search for a common traits ancestor." [| yts | (x isSameAs: y) ifTrue: [^ x traits]. yts: y allDelegates. x traits allDelegatesDo: [| :xt | (yts includes: xt) ifTrue: [^ xt]]. Nil ]. x@(Root traits) isReally: y@(Root traits) "Determine if anything in x's delegation chains equals y's traits. Do not override this." [| yt | yt: y traits. x traits == yt or: [x allDelegatesDo: [| :each | each == yt ifTrue: [^ True]]. False] ]. x@(Root traits) is: y@(Root traits) "The default for the protocol for testing properties. This is `blessed' to be overridden for optimization of queries and such." [x isReally: y]. x@(Root traits) as: y@(Root traits) "The default conversion method, as: returns a new object based on x which is as much like y as possible. If they are clone-family similar, just return the original object. Otherwise, the default is to raise a continuable Condition." [ (x isSameAs: y) ifTrue: [x] ifFalse: [x conversionNotFoundTo: y] ]. x@(Root traits) addProtectedSlot: slotName in: ancestorName valued: val "This creates a `protected slot', which means an immutable delegated slot that can be overridden from its default per object, making an effective customization policy. It works by ensuring that x delegates to the ancestor, then ensure that the ancestor has a slot of that name with that value, and finally define a method on the child to define a new slot on the *receiver* when mutations are attempted." [| delegate mutatorName | (x delegateNames includes: ancestorName) ifFalse: [^ Nil]. delegate: (x atSlotNamed: ancestorName). delegate addImmutableSlot: slotName valued: val. mutatorName: (intern: slotName name ; ':'). [| :obj :val | obj addSlot: slotName valued: val] asMethod: mutatorName on: {delegate. NoRole}. val ]. x@(Oddball traits) copy "While Oddballs are cloneable, copying shouldn't respect that." [x]. x@(Oddball traits) shallowCopy "While Oddballs are cloneable, copying shouldn't respect that." [x].