1 d@(Root traits) traitsTally
3 d traitsWindow _delegates size
6 d@(Derivable traits) traitsReverseDo: block
7 "Least important to most important traits"
10 tally := d traitsTally.
13 [block apply*, (d traitsWindow _delegates at: index).
17 d@(Derivable traits) traitsDo: block
18 "Most important to least important traits"
20 index := d traitsTally.
24 block apply*, (d traitsWindow _delegates at: index)]
27 d@(Derivable traits) orderTraits &mixins: mixins
28 "Answers an array of the traits objects in order..."
29 [| tally order index fixedOrder |
30 mixins `defaultsTo: #{}.
31 "TODO: Bootstrap-replace these two lines with the third (commented):"
32 tally := d traitsTally.
33 mixins do: [| :mixin | tally += mixin traitsTally].
34 "tally := (mixins gather: [| :mixin :tally | tally + mixin traitsTally] &initial: d traitsTally)."
35 order := mixins newSize: tally.
37 index := mixins size + 1.
39 order at: 0 put: d traits.
40 mixins doWithIndex: [| :each :i | order at: i + 1 put: each traits].
44 (order identityIncludes: traits)
46 [order at: index put: traits. index += 1]].
52 (order identityIncludes: traits)
54 [order at: index put: traits. index += 1]]].
56 (order first: index) reversed
60 "this one ignores the d object"
61 d@(Derivable traits) orderTraits: mixins
62 [| tally order index fixedOrder |
64 mixins do: [| :mixin | tally += mixin traitsTally].
65 order := Array newSize: tally.
67 mixins doWithIndex: [| :each :i | order at: i put: each traits].
75 (order identityIncludes: traits)
77 [order at: index put: traits. index += 1]]].
79 (order first: index) reversed
83 d@(Derivable traits) derive &mixins: mixins &rejects: rejectSlots
84 "Constructs and returns a new prototype based on the argument with a new
85 Traits object that delegates to the old one. If mixins are specified,
86 the Traits object inherits from each extra object's Traits in right-to-left
87 order. Also, the new prototype gains slots from the other objects involved,
88 except for those named rejects."
90 mixins `defaultsTo: #{}.
91 rejectSlots `defaultsTo: #{}.
92 newWindow := Cloneable clone.
93 newWindow restrictDelegation.
94 "newWindow _delegates: (d orderTraits &mixins: mixins)."
95 newWindow _delegates: (d orderTraits: mixins).
96 newWindow addDelegate: Cloneable clone. "the traits for this object"
98 newObj _delegates: {newWindow}.
99 mixins do: #(newObj addSlotsFrom: _) `er.
100 rejectSlots do: #(newObj removeSlot: _) `er.
104 x@(Root traits) addPrototype: protoName &parents: parents &immutable: immutable &basedOn: basedOn
105 "Creates a new prototype with the given name, handles derive calls
106 transparently, and sets the traits name slot to the name for convenience."
108 immutable `defaultsTo: False.
109 basedOn `defaultsTo: Cloneable.
110 parents `defaultsTo: {Cloneable}.
111 parents size = 0 ifTrue: [error: 'Parent objects must be supplied.'].
112 "newProto := ((parents at: 0) derive &mixins: (parents allButFirst: 1))."
113 newProto := (basedOn derive &mixins: parents).
114 immutable ifTrue: [newProto := newProto immutably].
115 "ensureSlot:is: may return the old value if =, but always returns what
116 is installed after the method is done."
117 (x hasSlotNamed: protoName)
118 ifTrue: [| oldProto |
119 oldProto := x atSlotNamed: protoName.
120 newProto := (x ensureSlot: protoName is: newProto
122 [| :old oldParents newParents |
123 "Modified equality using == over each delegate pair."
124 oldParents := old traitsWindow _delegates.
125 newParents := newProto traitsWindow _delegates.
126 oldParents size = newParents size
127 /\ [oldParents keySet allSatisfy:
128 [| :index | (oldParents at: index) == (newParents at: index)]]]).
129 newProto traitsWindow _delegates at: newProto traitsWindow _delegates size - 1 put: oldProto traits.
131 ifFalse: [x addImmutableSlot: protoName valued: newProto].
132 (x atSlotNamed: protoName) `>> [printName := protoName name. ]
135 x@(Root traits) printName: name
136 "Add a printName slot on the object's traitsWindow and its traits.
137 Override as necessary."
139 x traitsWindow addImmutableSlot: #printNameWindow valued: name.
140 x traits addImmutableSlot: #printNameTraits valued: name.
143 x@(Root traits) printName
146 [x hasSlotNamed: #printNameWindow] -> [x printNameWindow ; ' traitsWindow'].
147 [x hasSlotNamed: #printNameTraits] -> [x printNameTraits ; ' traits']
148 ) otherwise: [x traitsWindow printNameWindow]
151 x@(Root traits) printDelegates
153 x traitsWindow _delegates do: [| :d | inform: d printName].
156 x@(Root traits) addPrototype: protoName derivedFrom: parents &basedOn: basedOn
157 "Answer addPrototype:derivedFrom: with a default single parent of Cloneable."
158 [x addPrototype: protoName &parents: parents &basedOn: basedOn].
160 x@(Root traits) define: slotName recursivelyFrom: builder
161 "Creates a conservative new immutable slot holding the results of the block.
162 If such a slot already exists, recursively add slots from the built object
163 with their values in cases where the slots do not already exist in the
164 existing object. This is essentially a conservative object-slot tree builder."
167 (x hasSlotNamed: slotName)
169 [(x atSlotNamed: slotName)
170 ifNil: [x atSlotNamed: slotName put: new]
171 ifNotNilDo: #(addSlotsFromRecursively: new) `er]
172 ifFalse: [x addImmutableSlot: slotName valued: new].
173 x atSlotNamed: slotName
176 x@(Root traits) define: slotName using: builder
177 "Defines a new slot based on the result of running a block of code."
179 result := builder do.
180 x addImmutableSlot: slotName valued: result.
184 x@(Root traits) define: protoName &parents: parents &slots: slotSpecs
185 &builder: builder &namespace: ns &owner: obj &immutable: immutable
187 "Answer addPrototype:derivedFrom: with a default single parent of Cloneable."
189 immutable `defaultsTo: False.
190 slotSpecs `defaultsTo: #{}.
191 proto := builder ifNil: [x addPrototype: protoName &parents: parents &immutable: immutable &basedOn: basedOn]
192 ifNotNil: [x define: protoName using: builder].
195 each ifNotNil: [(each is: Association)
196 ifTrue: [(immutable ifTrue: [#addImmutableSlot:valued:] ifFalse: [#addSlot:valued:]) sendTo: {proto. each key. each value}]
197 ifFalse: [(immutable ifTrue: [#addImmutableSlot:] ifFalse: [#addSlot:]) sendTo: {proto. each}]]].
200 ifNil: [(x isSameAs: Namespace) /\
201 [(#surroundings findOn: {x}) ifNil: [True] ifNotNilDo: [| :m | (m apply*, proto) == x]]
202 ifTrue: [[| :_ | x] asMethod: #surroundings on: {proto traits}]]
203 ifNotNil: [[| :_ | ns] asMethod: #surroundings on: {proto traits}].
204 obj ifNotNil: [[| :_ | obj] asMethod: #owner on: {proto traits}]].
208 x@(Root traits) defineOddball: name &parents: parents
209 "Makes a new Oddball."
210 "TODO: handle the &parents: option."
211 [x define: name &builder: [Oddball clone]].
213 x@(Root traits) undefine: name
214 "Removes a previous slot definition."
219 x@(Cloneable traits) instancesSetting: slotNames to: values
221 values collect: [| :columnValues newX |
223 slotNames with: columnValues do:
224 [| :slotName :slotValue | newX atSlotNamed: slotName put: slotValue].
228 x@(Root traits) commentTemplate
229 "Answers a basic comment as a String for the object based on its definition."
230 [| slotNames delegateNames |
231 slotNames := x slotNames.
233 result ; x printName asAn capitalize ; ' is ' ; x traits printName asAn ; '.\n'.
236 [result ; 'Mixins: '.
237 x traitsDo: [| :trait | result ; trait printName ; ', '].
239 (#size findsSameMethodOn: {x} asOn: {Array})
240 ifTrue: [result ; 'It has indexable slots.\n'].
242 ifTrue: [result ; 'It has no named slots.']
244 [result ; 'It has named slots: '.
248 (val := x atSlotNamed: name)
249 ifNotNil: [result ; ' -> ' ; val printString].