src/core/root.slate

   1 "NOTE: Contains forward references to IdentitySet and ExtensibleArray."
   2
   3 "Core object functionality." (
   4
   5 x@(Root traits) = y@(Root traits)
   6 "Object equality; this should generally be overridden for each type that has
   7 some value semantics in its slots. When overriding this, also override the
   8 hash method for the kind of object, since hashing and equality testing are
   9 bound together for many container types."
  10 "The default equality is object identity."
  11 [x == y].
  12
  13 x@(Root traits) ~== y@(Root traits)
  14 "Whether the objects are not identical."
  15 [(x == y) not].
  16
  17 x@(Root traits) ~= y@(Root traits)
  18 "Whether the objects are not equal."
  19 [(x = y) not].
  20
  21 x@(Root traits) hash
  22 "The default hash value is the identity-based hash."
  23 [x identityHash].
  24
  25 x@(Root traits) shallowCopy
  26 "A cloning is a shallow copy. This is a Smalltalk idiom and may not be
  27 necessary for Slate, or may not be worth overriding."
  28 [x clone].
  29
  30 x@(Root traits) copy
  31 "Copy should return a new object which is = to the argument. The default is
  32 to return a clone. This should be overridden based on ='s overrides."
  33 [x shallowCopy].
  34
  35 x@(Root traits) new
  36 "New should return a new object which is 'fresh', meaning that it has some
  37 default appropriate state or lack-of-state. The default is to return a clone.
  38 This should be overridden whenever state is extended."
  39 [x clone].
  40
  41 ).
  42
  43 x@(Root traits) hasSlotNamed: slotName
  44 "Whether there is a slot defined with the given Symbol name on the object."
  45 [x slotNames identityIncludes: slotName].
  46
  47 x@(Root traits) hasDelegate: object
  48 [x _delegates identityIncludes: object].
  49
  50 x@(Root traits) accessorNameFor: slotName
  51 "Answer the default name for a Method to access the value of this slot;
  52 by default the slotName itself."
  53 [slotName].
  54
  55 x@(Root traits) mutatorNameFor: slotName
  56 "Answer the default name for a Method to access the value of this slot;
  57 by default the slotName appended with a colon."
  58 [| mutatorName nameString index |
  59   nameString := slotName name.
  60   mutatorName := nameString newSize: nameString size + 1.
  61   index := 0.
  62   [index = nameString size]
  63     whileFalse:
  64       [mutatorName at: index put: (nameString at: index).
  65        index += 1].
  66   mutatorName at: index put: $:.
  67   intern: mutatorName
  68 ].
  69
  70 x@(Root traits) defaultSlotValue
  71 "The default value for new slots for this object."
  72 [Nil].
  73
  74 x@(Root traits) addAccessor: method for: slotName &accessorName: accessorName
  75 [
  76   method
  77     asAccessor: (accessorName ifNil: [x accessorNameFor: slotName])
  78     for: slotName on: {x}
  79 ].
  80
  81 x@(Root traits) addAccessorFor: slotName &accessorName: accessorName
  82 "Adds and answers a new Method for accessing the slot's value,
  83 with overridable selector."
  84 [| m regCount slotNameReg primNumReg resultReg |
  85 "  x addAccessor: #(atSlotNamed: slotName) `er
  86     for: slotName &accessorName: accessorName"
  87
  88   "bypass method lookup by calling the primitive directly.
  89    because this is only defined on Root traits, we don't have to worry about the separate smallint primitive.
  90    now we just need to inline this into the caller to drop the interpreter_apply_to cost"
  91   m := [| :obj | ] clone. "this should not be a closure"
  92   regCount := m registerCount.
  93   m registerCount := regCount + 3.
  94   slotNameReg := regCount.
  95   primNumReg := regCount + 1.
  96   resultReg := regCount + 2.
  97   m code := {#[VM SSACode loadLiteral]. slotNameReg. slotName.
  98              #[VM SSACode loadLiteral]. primNumReg. 13.
  99              #[VM SSACode primitiveDo]. primNumReg. 2. resultReg. 0. slotNameReg.  "primNum, arg count, result reg, args..."
 100              #[VM SSACode returnRegister]. resultReg}.
 101   x addAccessor: m
 102     for: slotName &accessorName: accessorName
 103 ].
 104
 105 x@(Root traits) addMutator: method for: slotName &mutatorName: mutatorName
 106 [
 107   method
 108     asAccessor: (mutatorName ifNil: [x mutatorNameFor: slotName])
 109     for: slotName on: {x. NoRole}
 110 ].
 111
 112 x@(Root traits) addMutatorFor: slotName &mutatorName: mutatorName
 113 "Adds and answers a new Method for changing the slot's value,
 114 with overridable selector."
 115 [| m regCount slotNameReg primNumReg resultReg |
 116
 117   "bypass method lookup by calling the primitive directly.
 118    now we just need to inline this into the caller to drop the interpreter_apply_to cost"
 119   m := [| :obj :val | ] clone. "this should not be a closure"
 120   regCount := m registerCount.
 121   m registerCount := regCount + 3.
 122   slotNameReg := regCount.
 123   primNumReg := regCount + 1.
 124   resultReg := regCount + 2.
 125   m code := {#[VM SSACode loadLiteral]. slotNameReg. slotName.
 126              #[VM SSACode loadLiteral]. primNumReg. 15.
 127              #[VM SSACode primitiveDo]. primNumReg. 3. resultReg. 0. slotNameReg. 1.  "primNum, arg count, result reg, args..."
 128              #[VM SSACode returnRegister]. resultReg}.
 129   x addMutator: m
 130     for: slotName &mutatorName: mutatorName
 131 ].
 132
 133 x@(Root traits) rawAddSlot: slotName valued: slotValue
 134 [| newObj |
 135   newObj := x cloneWithSlot: slotName valued: slotValue.
 136   x forwardTo: newObj
 137 ].
 138
 139 x@(Root traits) addImmutableSlot: slotName valued: slotValue
 140 [
 141   (x hasSlotNamed: slotName)
 142     ifTrue: [x atSlotNamed: slotName put: slotValue]
 143     ifFalse: [x rawAddSlot: slotName valued: slotValue.
 144               x addAccessorFor: slotName.
 145               slotValue]
 146 ].
 147
 148 x@(Root traits) bind: slotName to: slotValue
 149 [
 150   (x hasSlotNamed: slotName)
 151     ifTrue: [x rebindOf: slotName]
 152     ifFalse: [x rawAddSlot: slotName valued: slotValue.
 153               (slotName findOn: {x}) ifNil: [x addAccessorFor: slotName].
 154               slotValue]
 155 ].
 156
 157 x@(Root traits) addSlot: slotName valued: slotValue
 158 [
 159   x addImmutableSlot: slotName valued: slotValue.
 160   x addMutatorFor: slotName.
 161   slotValue
 162 ].
 163
 164 x@(Root traits) addSlot: slotName
 165 "Adds a slot with default value, unless the slot is already present."
 166 [
 167   (x hasSlotNamed: slotName)
 168     ifTrue: [x atSlotNamed: slotName]
 169     ifFalse: [x addSlot: slotName valued: x defaultSlotValue]
 170 ].
 171
 172 x@(Root traits) addImmutableSlot: slotName
 173 "Adds a slot with default value, unless the slot is already present."
 174 [
 175   (x hasSlotNamed: slotName)
 176     ifTrue: [x atSlotNamed: slotName]
 177     ifFalse: [x addImmutableSlot: slotName valued: x defaultSlotValue]
 178 ].
 179
 180 x@(Root traits) addDelegate: slotValue
 181 [| newObj newDelegates |
 182   newDelegates := x _delegates copyWith: slotValue.
 183   x _delegates := newDelegates.
 184   x
 185 ].
 186
 187 x@(Root traits) insertDelegate: slotValue
 188 [| newObj newDelegates i |
 189   newDelegates := Array newSize: x _delegates size + 1.
 190   i := 0.
 191   [i = x _delegates size] whileFalse:
 192     [newDelegates at: i + 1 put: (x _delegates at: i). i += 1].
 193   newDelegates at: 0 put: slotValue.
 194   x _delegates := newDelegates.
 195   x
 196 ].
 197
 198 x@(Root traits) removeMutator: slotName
 199 [
 200   ((x mutatorNameFor: slotName) findOn: {x. NoRole})
 201     ifNotNilDo: [| :mutator |
 202       mutator removeFrom: {x. NoRole}].
 203 ].
 204
 205 x@(Root traits) addInvisibleSlot: slotName valued: slotValue
 206 "Adds a slot without any accessors, returning the value used."
 207 [
 208   x rawAddSlot: slotName valued: slotValue.
 209   x removeMutator: slotName.
 210   slotValue
 211 ].
 212
 213 x@(Root traits) removeSlot: slotName
 214 [| newObj |
 215   ((x accessorNameFor: slotName) findOn: {x})
 216     ifNotNilDo: [| :accessor |
 217       accessor removeFrom: {x}].
 218   ((x mutatorNameFor: slotName) findOn: {x. NoRole})
 219     ifNotNilDo: [| :mutator |
 220       mutator removeFrom: {x. NoRole}].
 221   newObj := x cloneWithoutSlot: slotName.
 222   x forwardTo: newObj
 223 ].
 224
 225 x@(Root traits) defaultDelegate
 226 "The default to delegate to; this should really not be used often."
 227 [Nil].
 228
 229 x@(Root traits) restrictDelegation
 230 "Sets the flag that marks this object->traits relationship as base-to-meta
 231 and therefore where to stop on method lookup. The map is replaced since we
 232 do not want to modify siblings in this way."
 233 [
 234   x _map := x _map clone.
 235   x _map flags := x _map flags bitOr: 1.
 236   x
 237 ].
 238
 239 x@(Root traits) cloneWithUpdates: slotsValuesArray
 240 "Wrapper of cloneSettingSlots:to: to take an array of Associations."
 241 [
 242   x cloneSettingSlots: (slotsValuesArray collect: #key `er)
 243     to: (slotsValuesArray collect: #value `er)
 244 ].
 245
 246 x@(Root traits) addSlots: col
 247 "Adds slots for all the names in the collection."
 248 [
 249   col do: #(x addSlot: _) `er.
 250   x
 251 ].
 252
 253 x@(Root traits) addSlotsFrom: another
 254 "Adds all slots from the other object to the first, with their values."
 255 "TODO: ensure it adds the accessor methods."
 256 [
 257   another slotNames do:
 258     [| :slotName |
 259      (x hasSlotNamed: slotName)
 260        ifFalse: [x addSlotNamed: slotName from: another]].
 261   x
 262 ].
 263
 264 x@(Root traits) addSlotsFromRecursively: another &seen: seen
 265 "Copies the subtree of all slots from the second argument to the first,
 266 using a seen-Set to avoid multiple visits."
 267 [
 268   (seen `defaultsTo: IdentitySet new)
 269     include: x.
 270   another slotNames do:
 271     [| :slotName |
 272      (x hasSlotNamed: slotName)
 273        ifTrue:
 274          [| obj |
 275           (seen identityIncludes: (obj := x atSlotNamed: slotName))
 276             ifFalse:
 277               [seen include: obj.
 278                obj addSlotsFromRecursively: (another atSlotNamed: slotName)
 279                    &seen: seen]]
 280        ifFalse: [x addSlotNamed: slotName from: another]].
 281   x
 282 ].
 283
 284 o@Nil addSlotsFromRecursively: _ [o].
 285 o addSlotsFromRecursively: _@Nil [o].
 286
 287 n@(SmallInteger traits) addSlotsFromRecursively: another [n].
 288
 289 x@(Root traits) addSlotNamed: slotName from: another
 290 [
 291   x addSlot: slotName valued: (another atSlotNamed: slotName)
 292 ].
 293
 294 x@(Root traits) addSlotsNamed: slotNames from: another
 295 "Add the slots with the given names from the other object to the first, with
 296 their values."
 297 "TODO: ensure that slot properties are carried over"
 298 [| otherSlotNames |
 299   otherSlotNames := another slotNames.
 300   slotNames
 301     do: [| :slotName |
 302          (anotherSlotNames identityIncludes: slotName)
 303            ifTrue: [x addSlotNamed: slotName from: another]].
 304   x
 305 ].
 306
 307 x@(Root traits) moveSlotNamed: slotName to: another
 308 "Adds the slot with the given name to the other object from the first, removing
 309 it then from the first."
 310 [
 311   (x hasSlotNamed: slotName)
 312     ifFalse: [x slotNotFoundNamed: slotName].
 313   another addSlotNamed: slotName from: x.
 314 ].
 315
 316 x@(Root traits) aliasSlotNamed: slotName as: another
 317 "Create accessor/mutator fake methods which access and update an existing slot,
 318 but using an interface that suggests that the slot is named differently."
 319 "TODO: Carry over mutability? Support aliasing to other objects."
 320 [
 321   x addAccessorFor: slotName &accessorName: (x accessorNameFor: another).
 322   x addMutatorFor: slotName &mutatorName: (x mutatorNameFor: another).
 323   x
 324 ].
 325
 326 x@(Root traits) renameSlot: slotName to: newName
 327 "Replaces the slot with a slot having the new name and the same value."
 328 [| slotValue |
 329   (x hasSlotNamed: slotName)
 330     ifFalse: [x slotNotFoundNamed: slotName].
 331   slotValue := x atSlotNamed: slotName.
 332   x removeSlot: slotName.
 333   x addSlot: newName valued: slotValue
 334 ].
 335
 336 x@(Root traits) ensureSlot: slotName is: newValue unlessSatisfies: testBlock
 337 "Adds a slot of the given name to the object if one isn't present already,
 338 initializing the new slot to the value. If a slot with that name is present
 339 already, test the existing one via the comparison block, and only update the
 340 slot if it fails. This always returns the resulting value of the slot."
 341 [
 342   (x hasSlotNamed: slotName)
 343     ifTrue: [| oldValue |
 344              oldValue := x atSlotNamed: slotName.
 345              (testBlock applyWith: oldValue)
 346                 ifTrue: [oldValue]
 347                 ifFalse: [x atSlotNamed: slotName put: newValue. newValue]]
 348     ifFalse: [x addSlot: slotName valued: newValue. newValue]
 349 ].
 350
 351 x@(Root traits) ensureSlot: slotName is: newValue
 352 "Adds a slot of the given name to the object if one isn't present already,
 353 initializing the new slot to the value. If a slot with that name is present
 354 already, compare the newValue with the existing one via =, and only update
 355 the slot if they're not equal. This always returns the resulting value of
 356 the slot."
 357 [
 358   x ensureSlot: slotName is: newValue
 359     unlessSatisfies: #(= newValue) `er
 360 ].
 361
 362 x@(Root traits) slotNamesAndValuesDo: block
 363 [
 364   x slotNames do:
 365     [| :slotName | block applyWith: slotName with: (x atSlotNamed: slotName)]
 366 ].
 367
 368 x@(Root traits) slotValuesDo: block
 369 "Apply the code to all the objects stored in the given one's slots."
 370 [
 371   x slotNames do: [| :slotName | block applyWith: (x atSlotNamed: slotName)]
 372 ].
 373
 374 x@(Root traits) slotValues
 375 [x slotNames collect: #(x atSlotNamed: _) `er].
 376
 377 x@(Root traits) delegatesDo: block
 378 "Apply the code to all the immediately delegated objects."
 379 [
 380   x _delegates do: #(block applyWith: _) `er
 381 ].
 382
 383 x@(Root traits) allDelegates &seen: seen
 384 "Answer all delegates recursively through the delegation chains, avoiding
 385 duplicates."
 386 [
 387   seen `defaultsTo: IdentitySet new.
 388   x delegatesDo:
 389     [| :delegate |
 390       (seen identityIncludes: delegate)
 391         ifFalse: [seen include: delegate.
 392                   delegate allDelegates &seen: seen]].
 393   seen
 394 ].
 395
 396 x@(Root traits) allSlotsDo: block &seen: seen
 397 "Apply the block to all slot values recursively through the slot chains,
 398 avoiding circularity and duplicates."
 399 [
 400   seen `defaultsTo: IdentitySet new.
 401   x slotValuesDo:
 402     [| :obj |
 403       (seen identityIncludes: obj)
 404         ifFalse: [seen include: obj.
 405                   block applyWith: obj.
 406                   obj allSlotsDo: block &seen: seen]].
 407 ].
 408
 409 x@(Root traits) allDelegatesDo: block &seen: seen
 410 "Recurse through the delegation chains, applying the block to each,
 411 avoiding circularity and duplicates."
 412 [
 413   seen `defaultsTo: IdentitySet new.
 414   x delegatesDo: [| :each |
 415     (seen identityIncludes: each)
 416       ifFalse:
 417         [seen include: each.
 418          block applyWith: each.
 419          each allDelegatesDo: block &seen: seen]].
 420 ].
 421
 422 x@(Root traits) allSlotsAndDelegatesDo: block &seen: seen
 423 [
 424   seen `defaultsTo: IdentitySet new.
 425   x slotValues ; x _delegates do:
 426     [| :obj |
 427      (seen identityIncludes: obj)
 428        ifFalse: [seen include: obj.
 429                  block applyWith: obj.
 430                  obj allSlotsAndDelegatesDo: block &seen: seen]].
 431 ].
 432
 433 x isSameAs: y@(Root traits)
 434 "Answer whether the two objects have the exact same shared behavior."
 435 [x traits == y traits].
 436
 437 x@(Root traits) commonAncestorWith: y@(Root traits)
 438 "Search for a common ancestor."
 439 [| yts |
 440   (x isSameAs: y) ifTrue: [^ x traits].
 441   yts := y allDelegates.
 442   x traits
 443     allDelegatesDo:
 444       [| :xt |
 445         (yts identityIncludes: xt)
 446           ifTrue: [^ xt]].
 447   Nil
 448 ].
 449
 450 x isReally: y@(Root traits)
 451 "Determine if anything in x's delegation chains equals y's traits.
 452 Do not override this."
 453 [| yt |
 454   yt := y traits.
 455   x traits == yt
 456     \/ [x allDelegatesDo:
 457           [| :each | each == yt ifTrue: [^ True]].
 458         False]
 459 ].
 460
 461 x is: y@(Root traits)
 462 "The default for the protocol for testing properties. This is `blessed' to
 463 be overridden for optimization of queries and such."
 464 [x isReally: y].
 465
 466 x as: y@(Root traits)
 467 "The default conversion method, as: returns a new object based on x which is
 468 as much like y as possible. If they are clone-family similar, just return the
 469 original object. Otherwise, the default is to raise a continuable Condition."
 470 [
 471   (x isSameAs: y)
 472     ifTrue: [x]
 473     ifFalse: [x conversionNotFoundTo: y]
 474 ].
 475
 476 x to: y@(Root traits)
 477 "The default attempt-conversion method, to: calls as: but in case of error
 478 just returns the source object."
 479 [
 480   [x as: y]
 481     on: ConversionNotFound
 482     do: [| :c | c return: c source]
 483 ].
 484
 485 "fix: make sure this works with non-named delegate model"
 486 x@(Root traits) addDynamicSlot: slotName valued: val
 487 "This creates a `dynamic slot', which means an immutable delegated slot
 488 that can be overridden from its default per object, making an effective
 489 customization policy.
 490 It works by ensuring that the object has a slot of that name with that value,
 491 and finally defining a mutator method on it to define a new slot on the
 492 *receiver* when mutations are attempted."
 493 [
 494   x addImmutableSlot: slotName valued: val.
 495   [| :obj :val | obj addSlot: slotName valued: val]
 496     asMethod: (x mutatorNameFor: slotName)
 497     on: {x. NoRole}.
 498   x
 499 ].
 500
 501 "fix: make sure this works with non-named delegate model"
 502 x@(Root traits) addLazySlot: slotName initializer: init
 503 "If the created slot is Nil then the accessor will call the init
 504 body and assign the returned value to the slot."
 505 [| newObj |
 506   newObj := x cloneWithSlot: slotName valued: x defaultSlotValue.
 507   [| :obj :val |
 508    obj addAccessorFor: slotName.
 509    obj addMutatorFor: slotName.
 510    obj atSlotNamed: slotName put: val]
 511     asAccessor: (x mutatorNameFor: slotName)
 512     for: slotName
 513     on: {newObj. NoRole}.
 514   [| :obj |
 515    obj addAccessorFor: slotName.
 516    obj addMutatorFor: slotName.
 517    obj atSlotNamed: slotName put: (init apply*, obj)]
 518     asAccessor: (x accessorNameFor: slotName)
 519     for: slotName
 520     on: {newObj}.
 521   x forwardTo: newObj
 522 ].
 523
 524 x@(Oddball traits) clone
 525 [x == Oddball
 526   ifTrue: [#clone sendTo: {x} through: {Cloneable}]
 527   ifFalse: [shouldNotImplement]
 528 ].
 529
 530 x@(Oddball traits) copy
 531 "While Oddballs are cloneable, copying shouldn't respect that."
 532 [x].
 533
 534 x@(Oddball traits) shallowCopy
 535 "While Oddballs are cloneable, copying shouldn't respect that."
 536 [x].