src/mobius/role.slate

   1 prototypes define: #RoleEntry &parents: {Cloneable}
   2   &slots: {#selector. #rolePositions. #methodDefinition}.
   3 "An object representing an entry in the object Map table for a method dispatch
   4 installation."
   5
   6 r1@(RoleEntry traits) = r2@(RoleEntry traits)
   7 [
   8   r1 selector == r2 selector
   9    /\ [r1 rolePositions = r2 rolePositions]
  10    /\ [r1 methodDefinition = r2 methodDefinition]
  11 ].
  12
  13 r@(RoleEntry traits) hash
  14 [
  15   (r selector hash bitXor: r rolePositions hash)
  16     bitXor: r methodDefinition hash
  17 ].
  18
  19 r@(RoleEntry traits) appliesToPosition: dispatchIndex
  20 [
  21   (r rolePositions >> dispatchIndex bitAnd: 1) = 1
  22 ].
  23
  24 prototypes define: #EmbeddedRoleEntry &parents: {RoleEntry}
  25   &slots: {#nextRoleIndex. #table}.
  26 "A RoleEntry subtype for describing the dispatch record installation as-is
  27 within the table, so that the table can be traversed."
  28
  29 r@(EmbeddedRoleEntry traits) nextRole
  30 [
  31   r nextRoleIndex ifNotNilDo: [| :index | r table at: index]
  32 ].
  33
  34 m@(Map traits) roleInTableAt: index
  35 "Takes a raw index into the RoleTable array and answers a RoleEntry object with
  36 that as starting index, or Nil if there is none."
  37 [
  38   (m roleTable at: index) ifNotNilDo:
  39     [| :selector |
  40      EmbeddedRoleEntry
  41        cloneSettingSlots:
  42          #(selector rolePositions methodDefinition nextRoleIndex)
  43        to: {selector.
  44             m roleTable at: index + 1.
  45             m roleTable at: index + 2.
  46             m roleTable at: index + 3}]
  47 ].
  48
  49 Map traits define: #RoleReadStream &parents: {ReadStream}
  50   &slots: {#map. #index -> 0 "The raw index into the role table."}.
  51 "An in-order traversal stream over the role-table in a Map, returning
  52 EmbeddedRoleEntry objects."
  53
  54 m@(Map RoleReadStream traits) on: map [m map: map. m].
  55
  56 m@(Map traits) roleReadStream [m RoleReadStream newOn: m].
  57
  58 obj@(Root traits) roleReader [obj _map roleReadStream].
  59
  60 m@(Map RoleReadStream traits) reset [m index: 0. m].
  61
  62 m@(Map RoleReadStream traits) elementType [RoleEntry].
  63
  64 m@(Map RoleReadStream traits) isAtEnd
  65 [m index > m map roleTable indexLast].
  66
  67 m@(Map RoleReadStream traits) next
  68 "TODO: prevent this from returning Nil when it reaches the end... raise Exhaustion?"
  69 [| result |
  70   [m isAtEnd] whileFalse:
  71     [result: (m map roleInTableAt: m index).
  72      m index: m index + 4.
  73      result ifNotNil: [^ result]]
  74 ].
  75
  76 x@(Root traits) roles
  77 "Answers all the roles applying to the object."
  78 [((x roleReader select: [| :role | role isNotNil]) >> {} writer) contents].
  79
  80 x@(Root traits) rolesAt: dispatchIndex
  81 "Answer the roles applying to the object at the given argument dispatch index."
  82 [
  83   ((x roleReader select:
  84     [| :role | role isNotNil /\ [role appliesToPosition: dispatchIndex]])
  85     >> {} writer) contents
  86 ].
  87
  88 x@(Root traits) roleIndices
  89 "Answer the position indices that the object has roles for."
  90 [| rolePositions |
  91   rolePositions: (x roleReader inject: 0 into:
  92     [| :positions :role | positions bitOr:
  93       (role ifNil: [0] ifNotNil: [role rolePositions])]) last.
  94   [| :result |
  95    (rolePositions as: BitArray) doWithIndex:
  96      [| :isRole :index | isRole ifTrue: [result nextPut: index]]] writingAs: {}
  97 ].
  98
  99 x@(Root traits) rolesNamed: selector
 100 "Answer the roles applying to the object for the given selector, in any
 101 position. This will not return duplicates."
 102 [
 103   ((x roleReader select:
 104     [| :role | role isNotNil /\ [role selector == selector]])
 105      >> IdentitySet new writer) contents
 106 ].
 107
 108 x@(Root traits) rolesNamed: selector at: dispatchIndex
 109 "Answer the roles applying to the object for the given selector, in the given
 110 position. This will not return duplicates."
 111 [
 112   ((x roleReader select:
 113     [| :role | role isNotNil /\ [role selector == selector] /\
 114        [role appliesToPosition: dispatchIndex]])
 115     >> IdentitySet new writer) contents
 116 ].
 117
 118 x@(Root traits) methods
 119 [x roles collect: [| :r | r methodDefinition method]].
 120
 121 x@(Root traits) accessorMethods
 122 [| selectors |
 123   selectors: (x slotNames collect: [| :s | x accessorNameFor: s]).
 124   (((x roleReader select: [| :r | selectors includes: r selector])
 125                  collect: [| :r | r methodDefinition method])
 126     >> IdentitySet new writer) contents
 127 ].
 128
 129 x@(Root traits) mutatorMethods
 130 [| selectors |
 131   selectors: (x slotNames collect: [| :s | x mutatorNameFor: s]).
 132   (((x roleReader select: [| :r | selectors includes: r selector])
 133                  collect: [| :r | r methodDefinition method])
 134     >> IdentitySet new writer) contents
 135 ].
 136
 137 x@(Root traits) methodsNamed: selector
 138 [
 139   (x rolesNamed: selector) select:
 140     [| :r | r selector = selector] collect: [| :r | r methodDefinition method]
 141 ].
 142
 143 x@(Root traits) hasMethodNamed: selector
 144 [
 145   x roleReader anySatisfy: [| :role | role selector == selector]
 146 ].
 147
 148 x@(Root traits) methodsNamed: selector at: dispatchIndex
 149 [
 150   (x rolesNamed: selector at: dispatchIndex) select:
 151     [| :r | r selector = selector] collect: [| :r | r methodDefinition method]
 152 ].
 153
 154 x@(Root traits) hasMethodNamed: selector at: dispatchIndex
 155 [
 156   x roleReader anySatisfy: [| :role | role selector == selector
 157                               /\ [role appliesToPosition: dispatchIndex]]
 158 ].
 159
 160 x@(Root traits) methodsAt: dispatchIndex
 161 [
 162   (x rolesAt: dispatchIndex)
 163     collect: [| :r | r methodDefinition method]
 164 ].
 165
 166 x@(Root traits) methodsSending: selector
 167 [
 168   ((x roleReader select:
 169     [| :r | r isNotNil /\
 170        [r methodDefinition method allSelectorsSent includes: selector]])
 171       >> [| :r | r methodDefinition method]
 172       >> IdentitySet new writer) contents
 173 ].
 174
 175 x@(Root traits) methodsSendingMacro: selector
 176 [
 177   [| :result |
 178    x roleReader do:
 179      [| :r m | m: (r ifNotNil: [r methodDefinition method]).
 180       (m isSameAs: CompiledMethod) ifTrue:
 181         [m sourceTree ifNotNilDo:
 182           [| :src |
 183            (src allMacroSelectorsSent includes: selector)
 184              ifTrue: [result nextPut: m]]]]]
 185     writingAs: IdentitySet
 186 ].