!=========================================================================
! Copyright (C) VMware, Inc. 1986-2011.  All Rights Reserved.
!
! $Id: gsmethoddictionary.gs,v 1.15 2008-01-09 22:50:11 stever Exp $
!
! gsmethoddictionary.gs
! 
! Superclass Hierarchy:
!   GsMethodDictionary, IdentityKeyValueDictionary, KeyValueDictionary,
!   Collection, Object.
!
!=========================================================================

! remove existing behavior from GsMethodDictionary
removeallmethods GsMethodDictionary
removeallclassmethods GsMethodDictionary

category: 'For Documentation Installation only'
classmethod: GsMethodDictionary
installDocumentation

| doc txt |
doc := GsClassDocumentation newForClass: self.

txt := (GsDocText new) details: 
'GsMethodDictionary optimizes IdentityKeyValueDictionary for use as method
 dictionaries in classes.  It employs a different internal structure that is
 well-suited for efficient execution in smaller dictionaries.  Changes to
 GsMethodDictionies are protected by the #CodeModification privilege, and
 therefore should not be used in customer applications.  For this purpose,
 you should use the subclass FastIdentityKeyValueDictionary.

 The keys of method dictionaries must be canonical symbols (Symbols or
 DoubleByteSymbols).

 Implementation details:
 Within the hash table, entries are of size two and contain key/value pairs:
    aSymbol, aValue
    nil,     SmallInteger - one-based offset of start of collision chain
    nil,     nil          - empty hash slot
 
 Collisions chains are linked lists within the root object itself, and
 are stored in the area after the hash table.  
 Collision list entries are triples (key, value, nextOffset):
    aSymbol, aValue, nextOffset - entry in chain, nextOffset is one-based
    aSymbol, aValue, nil        - end of chain
    nil,     nil,    nextOffset - empty element in collision chain, only
                                  removed by rebuildTable 
' .
doc documentClassWith: txt.

txt := (GsDocText new) details:
'The Class that specifies a constraint on the GsMethodDictionary''s values.
 If nil, there is no constraint.' .
doc documentInstVar: #valueConstraint with: txt.

txt := (GsDocText new) details:
'The Class that specifies a constraint on the GsMethodDictionary''s keys.
 If nil, there is no constraint.' .
doc documentInstVar: #keyConstraint with: txt.

self description: doc.
%


! ------------------- Class methods for GsMethodDictionary

! instance creation inherited from KeyValueDictionary

! ------------------- Instance methods for GsMethodDictionary

category: 'Private'
method: GsMethodDictionary
collisionBucketClass

"Returns the class of object to create when keys collide.
 GsMethodDictionary does not use collision buckets."

^ nil
%

! initialize: inherited from KeyValueDictionary 

category: 'Hashing'
method: GsMethodDictionary
hashFunction: aKey

"The hash function performs an operation on the value of the key aKey and
 returns some Integer between 1 and tableSize, inclusive."

^(aKey basicIdentityHash \\ self tableSize) + 1
%

category: 'Accessing'
method: GsMethodDictionary
at: aKey ifAbsent: aBlock

"Returns the value whose key is identical to aKey.  If no such key/value pair
 exists, returns the result of evaluating the zero-argument block aBlock."

| offset hashKey |

nil == aKey ifTrue:[ ^self _reportKeyNotFound: aKey with: aBlock ].

(hashKey := self _basicAt: 
       ( offset := (self hashFunction: aKey) * 2 - 1 )
  ) == aKey 
ifTrue:[
  ^ self _basicAt: offset + 1 . "the value"  
  ]
ifFalse:[
  nil == hashKey ifTrue:[ 
    "search collision chain"
    offset := self _basicAt: (offset + 1). "get one based offset to start of chain"
    [ offset == nil ] whileFalse:[
      (self _basicAt: offset )  == aKey ifTrue:[ 
        ^ self _basicAt: offset + 1 
        ].
      offset := self _basicAt: offset + 2 .
      ] .
    ].  
  ].
^ self _reportKeyNotFound: aKey with: aBlock .
%

category 'Accessing'
method: GsMethodDictionary
valueConstraint

"Returns the value constraint of the receiver."

^ valueConstraint
%

category 'Accessing'
method: GsMethodDictionary
keyConstraint

"Returns the key constraint of the receiver."

^ keyConstraint
%

category 'Updating'
method: GsMethodDictionary
valueConstraint: aClass

"Sets the value constraint of the receiver to aClass.  Generates an error if
 the receiver is not empty."

self _validatePrivilege.
self size > 0 ifTrue:[ ^ self _error: #rtErrCannotChgConstraint ].
valueConstraint := aClass
%

category 'Updating'
method: GsMethodDictionary
keyConstraint: aClass

"Sets the key constraint of the receiver to aClass.  Generates an error if
 the receiver is not empty."

self _validatePrivilege.
self size > 0 ifTrue:[ ^ self _error: #rtErrCannotChgConstraint ].
keyConstraint := aClass
%

category: 'Updating'
method: GsMethodDictionary
at: aKey put: aValue

"Stores the aKey/aValue pair in the hash dictionary.  Rebuilds the hash table
 if the addition caused the number of collisions to exceed the limit allowed.

 If aKey is not compatible with the key constraint of the receiver, or aValue is
 not compatible with the value constraint of the receiver, an error is
 generated."

| hashKey offset nextOffset newOffset emptyCollOffset |

self _validatePrivilege.
keyConstraint ~~ nil ifTrue:[
  (aKey isKindOf: keyConstraint)  ifFalse:[
    aKey _error: #rtErrInvalidArgClass args:#[ keyConstraint ].
    ].
  ].
valueConstraint ~~ nil ifTrue:[
  (aValue isKindOf: valueConstraint) ifFalse:[
    aValue _error: #rtErrInvalidArgClass args:#[ valueConstraint ].
    ].
  ].
(hashKey := self _basicAt: ( offset := (self hashFunction: aKey) * 2 - 1)) 
== aKey ifTrue:[
  self _basicAt: offset + 1 put: aValue .
  ]
ifFalse:[
  hashKey == nil ifTrue:[
    "possible empty hash slot "
    nextOffset := self _basicAt: (offset + 1) .
    nextOffset == nil ifTrue:[
      "empty hash slot"
      numElements := numElements + 1 .
      self _basicAt: offset put: aKey .
      self _basicAt: offset + 1  put: aValue .
      ^ aValue
      ].
    ]
  ifFalse:[
    "non-empty hash slot, move contents of hashSlot to first entry in
        a new collision chain"
    nextOffset := self _basicSize + 1 .  "nextOffset is one based"
    self _basicSize: nextOffset + 2 .
    self _basicAt: nextOffset put: hashKey .
    self _basicAt: nextOffset + 1 put: (self _basicAt: (offset + 1)) . "value"
       " _basicAt: nextOffset + 2  left as nil, end of collision chain "
    self _basicAt: offset put: nil .
    self _basicAt: (offset + 1) put: nextOffset "head of chain" .
    ].
  "search collision chain"
  emptyCollOffset := -1  .
  [
    offset := nextOffset . 
    hashKey := (self _basicAt: offset ) .
    hashKey == aKey ifTrue:[ 
      "replace value for an existing key "
      self _basicAt: offset + 1 put: aValue . 
      ^ aValue 
      ].
    hashKey == nil ifTrue:[
      "remember location of first empty collision chain entry"
      emptyCollOffset < 0 ifTrue:[ emptyCollOffset := offset ].
      ].
    (nextOffset := self _basicAt: offset + 2 ) == nil
    ] untilTrue .
  "offset is now pointing at last hash slot in the chain"
  emptyCollOffset > 0 ifTrue:[
    "reuse empty collision chain entry"
    self _basicAt: emptyCollOffset put: aKey.
    self _basicAt: emptyCollOffset + 1 put: aValue .
    numElements := numElements + 1 .
    ^ aValue 
    ].
  newOffset := self _basicSize + 1.
  self _basicSize: newOffset + 2 .
  self _basicAt: newOffset put: aKey .
  self _basicAt: newOffset + 1 put: aValue.  
  "newOffset + 2 left as nil"
  self _basicAt: offset + 2 put: newOffset .  "link to the preceding end of chain"
  numElements := numElements + 1 .
  numCollisions := numCollisions + 1 .
  (numCollisions > collisionLimit) ifTrue: [
    self rebuildTable: (Integer _selectedPrimeGreaterThan: tableSize * 2)
    ].
  ].
^ aValue
%

category: 'Private'
method: GsMethodDictionary
atHash: hashIndex putValue: aValue

"Disallowed."

self shouldNotImplement: #atHash:putValue:
%

category: 'Private'
method: GsMethodDictionary
atHash: hashIndex putKey: aValue

"Disallowed."

self shouldNotImplement: #atHash:putKey:
%

category: 'Accessing'
method: GsMethodDictionary
at: aKey otherwise: aValue

"Returns the value whose key is identical to aKey.  If no such key/value pair
 exists, returns the given alternate value."

" not optimized"

^ self at: aKey ifAbsent:[ aValue ]
%

category: 'Removing'
method: GsMethodDictionary
removeKey: aKey ifAbsent: aBlock

"Removes the key/value pair whose key is identical to aKey.  If no such
 key/value pair exists, returns the result of evaluating the zero-argument
 block aBlock."

| hashKey offset valueRemoved |

self _validatePrivilege.
nil == aKey ifTrue:[ ^self _error: #rtErrNilKey ].

(hashKey := self _basicAt: ( offset := (self hashFunction: aKey) * 2 - 1)) 
== aKey ifTrue:[
  "remove from hash slot that does not have any collisions"
  self _basicAt: offset put: nil .
  valueRemoved := self _basicAt: offset + 1 .
  self _basicAt: offset + 1 put: nil .
  numElements := numElements - 1 .
  ^ valueRemoved
  ]
ifFalse:[
  hashKey == nil ifTrue:[
    "search collision chain"
    offset := self _basicAt: offset + 1 .  "get one based offset"
    [ offset == nil ] whileFalse:[
      (self _basicAt: offset )  == aKey ifTrue:[
        "remove entry from collision chain"
        valueRemoved := self _basicAt: offset + 1 .
        self _basicAt: offset put: nil .  "make collision chain element empty"
        self _basicAt: offset + 1 put: nil .
        numElements := numElements - 1 .  "do not decrement numCollisions"
        ^ valueRemoved
        ].
      offset := self _basicAt: offset + 2   . "get one based offset"
      ] .
    ].
  ^ self _reportKeyNotFound: aKey with: aBlock
  ]
%

! added for 36675
category: 'Removing'
method: GsMethodDictionary
removeKey: aKey otherwise: notFoundValue

"Removes the key/value pair whose key is identical to aKey.  If no such
 key/value pair exists, returns the result of evaluating the zero-argument
 block aBlock."

| hashKey offset valueRemoved |

self _validatePrivilege.
nil == aKey ifTrue:[ ^self _error: #rtErrNilKey ].

(hashKey := self _basicAt: ( offset := (self hashFunction: aKey) * 2 - 1)) 
== aKey ifTrue:[
  "remove from hash slot that does not have any collisions"
  self _basicAt: offset put: nil .
  valueRemoved := self _basicAt: offset + 1 .
  self _basicAt: offset + 1 put: nil .
  numElements := numElements - 1 .
  ^ valueRemoved
  ]
ifFalse:[
  hashKey == nil ifTrue:[
    "search collision chain"
    offset := self _basicAt: offset + 1 .  "get one based offset"
    [ offset == nil ] whileFalse:[
      (self _basicAt: offset )  == aKey ifTrue:[
        "remove entry from collision chain"
        valueRemoved := self _basicAt: offset + 1 .
        self _basicAt: offset put: nil .  "make collision chain element empty"
        self _basicAt: offset + 1 put: nil .
        numElements := numElements - 1 .  "do not decrement numCollisions"
        ^ valueRemoved
        ].
      offset := self _basicAt: offset + 2   . "get one based offset"
      ] .
    ].
  ^ notFoundValue
  ]
%

category: 'Removing'
method: GsMethodDictionary
removeAll

"Remove all key/value pairs from the receiver."

self _validatePrivilege.
self _basicSize: 0 . "dereference all keys and values"
self _basicSize: tableSize * 2 .  "reinitialize hash table to all nils"
numElements := 0 .
numCollisions := 0 
%

! tableSize: inherited from KeyValueDictionary
! rebuildTable:  inherited from KeyValueDictionary

category: 'Copying'
method: GsMethodDictionary
copy

"Returns a copy of the receiver which shares the receiver's instance
 variables."

"Just copy the root node - there are no collision buckets to copy.
 Since copy is reimplemented in KeyValueDictionary, this implementation must
 bypass that and call the primitive in Object directly."

<primitive: 55>
self _primitiveFailed: #copy .
self _uncontinuableError
%

category: 'Accessing'
method: GsMethodDictionary
keyAtValue: anObject ifAbsent: aBlock

"Returns the key of the first value identical to anObject.  If no
 match is found, this method evaluates the block aBlock and returns its
 result."

self keysAndValuesDo:[ :aKey :aValue |
  anObject == aValue ifTrue:[ ^ aKey ]
  ].
^ aBlock value
%

category: 'Enumerating'
method: GsMethodDictionary
keysAndValuesDo: aBlock

"Evaluates aBlock with each of the receiver's key/value pairs as the
 arguments.  The argument aBlock must be a two-argument block.  The
 first argument is the key and the second argument is the value of
 each key/value pair.  Returns the receiver."

| aKey tSize |

"process hash slots"
tSize := tableSize * 2 .
1 to: tSize by: 2 do: [ :offset |
  nil == (aKey := self _basicAt: offset) ifFalse:[
    aBlock value: aKey value: (self _basicAt: offset + 1) .
    ].
  ].
"process collision chains"
tSize + 1 to: self _basicSize by: 3 do:[:offset |
  (aKey := self _basicAt: offset) == nil ifFalse:[ 
    aBlock value: aKey value: (self _basicAt: offset + 1) .
    ].
  ].
%

! added for 36675
category: 'Enumerating'
method: GsMethodDictionary
inject: anObj keysAndValuesInto: aBlock

"Evaluates aBlock with each of the receiver's key/value pairs as the
 2nd and 3rd arguments.
 aBlock must be a 3 argument block, with arguments anObj, key value ."

| aKey tSize |
"process hash slots"
tSize := tableSize * 2 .
1 to: tSize by: 2 do: [ :offset |
  nil == (aKey := self _basicAt: offset) ifFalse:[
    aBlock value: anObj value: aKey value: (self _basicAt: offset + 1) .
    ].
  ].
"process collision chains"
tSize + 1 to: self _basicSize by: 3 do:[:offset |
  (aKey := self _basicAt: offset) == nil ifFalse:[
    aBlock value: anObj value: aKey value: (self _basicAt: offset + 1) .
    ].
  ].
%

category: 'Enumerating'
method: GsMethodDictionary
associationsDo: aBlock

"Evaluates aBlock with each of the receiver's key/value pairs as the argument by
 creating a SymbolAssociation for each key/value pair.  The argument aBlock must
 be a one-argument block.  Returns the receiver."

self keysAndValuesDo: [:aKey :aValue |
  aBlock value: (SymbolAssociation newWithKey: aKey value: aValue)
  ].
%

category: 'Statistics'
method: GsMethodDictionary
statistics

"A GsMethodDictionary has no collision buckets, so the statistics defined
 for KeyValueDictionary have no meaning."

^ nil
%

! detectValues:ifNone: inherited
! selectValues: inherited

! inherited  rejectValues: aBlock
! inherited selectValuesAsArray:
! inherited rejectValuesAsArray:

category: 'Formatting'
method: GsMethodDictionary
printOn: aStream

"Puts a displayable representation of the receiver on the given stream."

"copy the implementation from Object."

aStream nextPutAll: self asString
%

! deleted _canonicalizeSymbolAt: offset oldSymbol: oldSym newSymbol: newSym

category: 'Canonical Symbol Support'
method: GsMethodDictionary
_selectiveAbort

"Performs an abort operation on the receiver."

"Receiver is just an ordinary small or large object as far as selective abort is
 concerned, so execute the implementation in Object.  Must avoid the
 reimplementation in IdentityKeyValueDictionary, so can't use super."
  
^ self _primitiveSelectiveAbort
%

category: 'Clustering'
method: GsMethodDictionary
clusterDepthFirst

"This method clusters the receiver and its values in depth-first order.  The
 keys are not clustered because they are Symbols.

 Has no effect and returns true if the receiver was previously clustered in the
 current transaction."

self cluster
  ifTrue:[ ^ true ]
  ifFalse: [ 
      "none of the named instance variables should be clustered"

      self doValues:[:aMethod | aMethod clusterDepthFirst ].
      ^ false
    ]
%


category: 'Hashing'
method: GsMethodDictionary
rebuildTable: newSize

"Rebuilds the method dictionary by populating a larger method dictionary
 first and doing a (primitive) become:"

"NOTE: This method is reimplemented and reinstalled in bomlast.gs to handle
instances that have a dependency list, used for modification tracking."

<primitive: 901>  "enter protected mode"
| newGsMethodDict |

self _validatePrivilege.
tableSize == newSize ifTrue:[ ^ self "no change in table size" ].
collisionLimit == 536870911 ifTrue:[
  System _disableProtectedMode .
  ^ self  "avoid recursive rebuild"
  ].

newGsMethodDict := self class new: (newSize * 2).
newGsMethodDict valueConstraint: valueConstraint.
newGsMethodDict keyConstraint: keyConstraint.

self keysAndValuesDo: [ :aKey :aValue |
  newGsMethodDict at: aKey put: aValue.
  ].

newGsMethodDict _primitiveBecome: self.
System _disableProtectedMode.
%

category: 'Initializing'
method: GsMethodDictionary
initialize: newSize

"Initializes the instance variables of the receiver to be an empty
 IdentityKeyValueDictionary of the specified size."

self _validatePrivilege.
super initialize: newSize .
collisionLimit := newSize // 4
%

category: 'Private'
method: GsMethodDictionary
_resetParentRef

"Private. After a become:, the parent refs of the collisionBuckets must 
 be reset to point to the correct parent."

"GsMethodDictionarys don't use collision buckets"

^self

%

category: 'CodeModification Override'
method: GsMethodDictionary
instVarAt: anIndex put: aValue

self _validatePrivilege.
^ super instVarAt: anIndex put: aValue
%

category: 'CodeModification Override'
method: GsMethodDictionary
_basicAt: anIndex put: aValue

self _validatePrivilege.
^ super _basicAt: anIndex put: aValue
%

category: 'CodeModification Override'
method: GsMethodDictionary
_basicSize: anInteger

self _validatePrivilege.
^ super _basicSize: anInteger
%

category: 'CodeModification Override'
method: GsMethodDictionary
_primitiveAt: anIndex put: aValue

self _validatePrivilege.
^ super _primitiveAt: anIndex put: aValue
%

category: 'CodeModification Override'
method: GsMethodDictionary
_unsafeAt: anIndex put: aValue

self _validatePrivilege.
^ super _unsafeAt: anIndex put: aValue
%

category: 'CodeModification Override'
method: GsMethodDictionary
_validatePrivilege

( self isMemberOf: GsMethodDictionary ) ifTrue: [
    System myUserProfile _validateCodeModificationPrivilege 
    ]
%

category: 'Updating'
method: GsMethodDictionary
changeToSegment: segment

"Assigns the receiver to the given segment."

self assignToSegment: segment
%


!-------------------------------------------------------------------------
! NOTE:
! The method GsMethodDictionary>>rebuildTable: is reimplemented and
! reinstalled in bomlast.gs to handle instances that have a dependency list
!-------------------------------------------------------------------------


