!=========================================================================
! Copyright (C) VMware, Inc. 1986-2011.  All Rights Reserved.
!
! $Id: clampsp.gs,v 1.8 2008-01-09 22:50:09 stever Exp $
!
! Superclass Hierarchy:
!   ClampSpecification, Object.
!
!=========================================================================

! BUGFIX 31162: use of GsMethodDictionary in instVarLevels
! replaced with new subclass FastIdentityKeyValueDictionary

expectvalue %String
run
^ Object _newKernelSubclass: 'ClampSpecification'
        instVarNames: #( 'idClamps' 'classClamps' 'instVarLevels'
                         'addSubleafHeaders' 'useIdBitMap'
	                 'traversalCallBackSelector' 'valueClamps')
        classVars: #()
        classInstVars: #()
        poolDictionaries: #[]
        inDictionary: Globals
        constraints: #[ #[ #idClamps, IdentitySet ],
                        #[ #classClamps, ClassSet ],
                        #[ #instVarLevels, FastIdentityKeyValueDictionary ],
                        #[ #addSubleafHeaders, Boolean ],
                        #[ #useIdBitMap, Boolean ],
		        #[ #traversalCallBackSelector, Symbol ],
		        #[ #valueClamps, IdentitySet ] ]
        instancesInvariant: false
        isModifiable: false
        reservedOop: 861
%

removeallmethods ClampSpecification
removeallclassmethods ClampSpecification

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

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

txt := (GsDocText new) details:
'A ClampSpecification represents a set of clamps to be applied to operations
 that traverse object structures.  ClampSpecification objects are required
 during clamped object traversal.' .
doc documentClassWith: txt.

txt := (GsDocText new) details:
'An IdentitySet of objects to be clamped by identity (OOP).'.
doc documentInstVar: #idClamps with: txt.

txt := (GsDocText new) details:
'A ClassSet of class objects whose instances are to be clamped during object
 traversal.'.
doc documentInstVar: #classClamps with: txt.

txt := (GsDocText new) details:
'A FastIdentityKeyValueDictionary whose keys are Classes and whose values are
 Arrays of SmallIntegers.  The Array value for a given class key has an element
 for every named instance variable of that class and has one additional element
 for any unnamed instance variables.  The value of each Array element is nil if
 the variable for that element does not have an instance variable level.  
 Otherwise, it is a SmallInteger or false.  If it is a SmallInteger, then its 
 absolute value is the number of instance variable levels.  If the SmallInteger
 is negative, it represents a min operation; if it is positive, it represents a
 max operation.  The SmallInteger zero represents a max operation; there is no
 representation for a min operation of zero.  If it is false then this is like
 max 0 with the exception that a subleaf header will not be included.' .
doc documentInstVar: #instVarLevels with: txt.

txt := (GsDocText new) details:
'A Boolean that denotes whether or not subleaf headers should be collected
 in the traversal.  If true, then the object report header of objects that
 are one level below the cut off line will be put in the traversal buffer.'.
doc documentInstVar: #addSubleafHeaders with: txt.

txt := (GsDocText new) details:
'IGNORED in this release, traversal code always uses
 the idClamps IdentitySet directly.

 OLD BEHAVIOR:
   A Boolean that denotes whether or not the low level C code should convert
 idClamps to a bitmap.  The default is not to do the conversion and just to
 probe into the original set.  If idClamps is very large, it is best not to
 convert to bitmaps for performance reasons.'.
doc documentInstVar: #useIdBitMap with: txt.

txt := (GsDocText new) details:
'A symbol selector that is used to place alternative value buffer contents
for objects whose format indicates that they should use the callback.'.
doc documentInstVar: #traversalCallBackSelector with: txt.

txt := (GsDocText new) details:
'An IdentitySet that contains objects that have been value-clamped during
traversal calls.'.
doc documentInstVar: #valueClamps with: txt.

self description: doc.
%

category: 'Examples'
classmethod: ClampSpecification
example1

"Creates and returns a ClampSpecification object with identity clamps for
 Globals and AllUsers, class clamps for Segment, Repository and UserProfile, and
 instance variable levels on the value parts of Associations and
 SymbolAssociations."

^ClampSpecification newWithIdClamps: #[ Globals, AllUsers ]
  classClamps: #[ Segment, Repository, UserProfile ]
  instVarLevels: #[
      #[ Association, #( #value 0 ) ],
      #[ SymbolAssociation, #( #value 0 ) ]
      ]
%

category: 'Examples'
classmethod: ClampSpecification
example2

"Same as example1, but the clamps are added piecemeal."

| inst |
inst := ClampSpecification new.
inst addAllIdClamps: #[ Globals, AllUsers ].
inst addAllClassClamps: #[ Segment, Repository, UserProfile ].
inst addAllInstVarLevels: #[
    #[ Association, #( #value 0 ) ],
    #[ SymbolAssociation, #( #value 0 ) ]
    ].
^inst
%

category: 'Instance Creation'
classmethod: ClampSpecification
new

"Returns a new instance of ClampSpecification.  Note that you may also use
 structural access calls through GemBuilder for either C or Smalltalk
 (for example, GciNewOop()) to create new instances of ClampSpecification."

^super new
%

category: 'Instance Creation'
classmethod: ClampSpecification
new: anInteger

"Disallowed.  You may not use this method to create new instances of
 ClampSpecification."

^self shouldNotImplement: #new:
%

category: 'Instance Creation'
classmethod: ClampSpecification
newWithIdClamps: idClamps
classClamps: classClamps
instVarLevels: instVarLevels

"Creates and returns a new instance of ClampSpecification with the given clamps.
 If a creation error is encountered, generates an error but does not return the
 new ClampSpecification."

| inst |

inst := self new.
inst addAllIdClamps: idClamps;
     addAllClassClamps: classClamps;
     addAllInstVarLevels: instVarLevels.
^inst
%

category: 'Instance Creation'
classmethod: ClampSpecification
newWithIdClamps: idClamps
classClamps: classClamps
instVarLevels: instVarLevels
subleafHeaders: subleafHeadersBool

"Creates and returns a new instance of ClampSpecification with the given clamps.
 If subleafHeadersBool is true, a traversal using this clamp supplies object
 headers for objects that are children of the leaf nodes of the traversal.
 If a creation error is encountered, generates an error but does not return the
 new ClampSpecification."

| inst |

inst := self
   newWithIdClamps: idClamps
   classClamps: classClamps
   instVarLevels: instVarLevels.
inst addSubleafHeaders: subleafHeadersBool.

^inst
%

category: 'Instance Creation'
classmethod: ClampSpecification
newWithIdClampsHolder: idClamps
classClamps: classClamps
instVarLevels: instVarLevels
subleafHeaders: subleafHeadersBool
traversalCallbackSelector: callbackSelector

"Creates and returns a new instance of ClampSpecification with the given clamps.
 The argument idClamps is the actual IdentitySet used to hold the identity
 clamps, so it must be an instance of IdentitySet.  If subleafHeadersBool
 is true, a traversal using this clamp supplies object headers for objects that
 are children of the leaf nodes of the traversal.  The callbackSelector is
 either nil or a unary selector symbol that is used by the traversal mechanism
 to send to instances of classes that require a traversal callback."

| inst |

inst := self basicNew
   _initIdClampsHolder: idClamps
   classClamps: classClamps
   instVarLevels: instVarLevels
   addSubleafHeaders: subleafHeadersBool
   traversalCallbackSelector: callbackSelector.

^inst
%

category: 'Instance Variable Levels'
method: ClampSpecification
addAllInstVarLevels: aCollection

"Adds the given instance variable levels to the receiver.  The argument
 aCollection may be either (1) an Array of two-element Arrays, in which the
 first element of each Array is a Class object and the second element is
 a collection of instance variable levels in the format expected by
 addInstVarLevels:forClass:,
 or (2) a Dictionary whose keys are Class objects and whose values are
 collections of instance variable levels in the format expected by
 addInstVarLevels:forClass:.  Returns the receiver."

aCollection _validateClass: Collection .
(aCollection isKindOf: Dictionary)
  ifTrue: [
    aCollection doAssociations: [:each |
      self addInstVarLevels: (each value) forClass: (each key)
    ]
  ]
  ifFalse: [
    aCollection do: [:each |
      (each size == 2) ifFalse:[
        each _error: #clampErrBadArg args:  #()  .  ^ self
      ].
      ((each at:2) class isBytes) ifTrue:[
         (each at:2) _error: #clampErrBadArg args:  #()  .  ^ self
      ].
      self addInstVarLevels: (each at: 2) forClass: (each at: 1)
    ]
  ].
%

category: 'Instance Variable Levels'
method: ClampSpecification
addInstVarLevels: aCollectionOfIVarLevels forClass: aClass

"Adds an instance variable level on each of the instance variable names
 contained in aCollectionIVarLevels for the specified class aClass.  The levels
 must be an OrderedCollection in the following format:

 1. A Symbol specifying the named instance variable to level or nil to level all
    unnamed instance variables.
 2. A SmallInteger that specifies the level, or false.  If false, then treat it
    as a max 0 but never include a subleaf header.  If this value is less than
    zero then it is a min operation.  Otherwise it is a max operation."

| allivs   "the list of all the instance variable for aClass"
  ivlArray "the instance variable level Array"
|

aCollectionOfIVarLevels _validateClass: Collection .
(aCollectionOfIVarLevels class isBytes) ifTrue:[
  aCollectionOfIVarLevels _error: #clampErrBadArg args:  #()  .
  ^ self
].

(aClass class class) == Metaclass ifFalse: [
    aClass _error: #clampErrNotAClass args:  #().
    ^ self
].

instVarLevels == nil ifTrue: [self _initializeInstVarLevels].

allivs := aClass _instVarNames.

ivlArray := Array new.
ivlArray size: (allivs size) + 1.

1 to: (aCollectionOfIVarLevels size) by: 2 do: [ :i | | varname level idx |
  varname := aCollectionOfIVarLevels at: i.
  level := aCollectionOfIVarLevels at: i+1.
  varname == nil ifTrue: [idx := allivs size + 1]
                ifFalse: [
    idx := allivs indexOfValue: varname.
    idx == 0 ifTrue: [
      ^aClass _error: #clampErrNoSuchInstvar args: #[varname].
    ].
  ].
  ivlArray at: idx put: level.
].
instVarLevels at: aClass put: ivlArray.
%

category: 'Instance Variable Levels'
method: ClampSpecification
includesInstVarLevelsFor: aClass

"Returns true if the receiver has an instance variable level on aClass.
 Returns false otherwise."

instVarLevels == nil ifTrue:  [^false]
                    ifFalse: [^instVarLevels includesKey: aClass]
%

category: 'Instance Variable Levels'
method: ClampSpecification
removeInstVarLevelsFor: aClass

"Removes any existing instance variable levels for aClass.  Generates an error
 if there is no instance variable level on aClass."

instVarLevels == nil ifTrue:  [self _errorKeyNotFound: aClass. ^self]
                    ifFalse: [^instVarLevels removeKey: aClass]
%

category: 'Class Clamps'
method: ClampSpecification
addAllClassClamps: aCollection

"Adds a class clamp to the receiver for each class object in aCollection.
 The instances of each class in aCollection will be clamped during
 object traversal."

aCollection _validateClass: Collection .
classClamps == nil ifTrue: [self _initializeClassClamps].
(aCollection class isBytes) ifTrue:[
  aCollection _error: #clampErrBadArg args:  #()  .
  ^ self
].
classClamps addAll: aCollection.
%

category: 'Class Clamps'
method: ClampSpecification
addClassClampFor: aClass

"Adds a class clamp to the receiver for aClass.  Returns the receiver."

classClamps == nil ifTrue: [self _initializeClassClamps].
classClamps add: aClass.
%

category: 'Class Clamps'
method: ClampSpecification
includesClassClampFor: aClass

"Returns true if the receiver has a class clamp on aClass.  Returns false
 otherwise."

classClamps == nil ifTrue:  [^false]
                  ifFalse: [^classClamps includesIdentical: aClass]
%

category: 'Class Clamps'
method: ClampSpecification
removeClassClampFor: aClass

"Removes the class clamp from the receiver for aClass.  Generates an error if
 there is no class clamp on aClass."

classClamps == nil ifTrue:  [self _errorNotFound: aClass. ^self]
                  ifFalse: [^classClamps remove: aClass]
%

category: 'Testing'
method: ClampSpecification
addSubleafHeaders

"Returns true if the receiver will add subleaf headers to the traversal buffer.
 Returns false otherwise."

addSubleafHeaders == nil ifTrue:  [^false]
                        ifFalse: [^addSubleafHeaders]
%

category: 'Testing'
method: ClampSpecification
useIdBitMap

"Returns true if the receiver will use a bitmap when doing the traversal.
 Returns false otherwise."

^ false
%

category: 'Configuration'
method: ClampSpecification
addSubleafHeaders: aBoolean

"Sets the addSubleafHeaders instance variable to aBoolean.  Returns the
 receiver."

addSubleafHeaders := aBoolean.

^self
%

category: 'Accessing'
method: ClampSpecification
traversalCallBackSelector

"Returns the value of the instance variable traversalCallBackSelector."

^ traversalCallBackSelector
%

category: 'Configuration'
method: ClampSpecification
traversalCallBackSelector: aSelector

"Sets the traversalCallBackSelector instance variable to aSelector.
 aSelector must be a Symbol or DoubleByteSymbol.  Returns the receiver."

traversalCallBackSelector := aSelector
%

category: 'Configuration'
method: ClampSpecification
useIdBitMap: aBoolean

"HAS NO EFFECT, argument is ignored "

"OLD: Sets the useIdBitMap instance variable to aBoolean.  Returns the receiver."

useIdBitMap := false .
^self
%

category: 'Identity Clamps'
method: ClampSpecification
addAllIdClamps: aCollection

"Adds an identity clamp to the receiver for each object in aCollection.
 Returns the receiver."

aCollection _validateClass: Collection .
idClamps == nil ifTrue: [self _initializeIdClamps].
idClamps addAll: aCollection.
%

category: 'Identity Clamps'
method: ClampSpecification
addIdClampFor: anObject

"Adds an identity clamp to the receiver for anObject.  Returns the receiver."

anObject isSpecial ifTrue: [ ^ anObject _error: #clampErrBadArg args: #() ].
idClamps == nil ifTrue: [self _initializeIdClamps].
idClamps add: anObject.
%

category: 'Identity Clamps'
method: ClampSpecification
includesIdClampFor: anObject

"Returns true if the receiver has an identity clamp on anObject.
 Returns false otherwise."

idClamps == nil ifTrue:  [^false]
               ifFalse: [^idClamps includesIdentical: anObject]
%

category: 'Identity Clamps'
method: ClampSpecification
removeIdClampFor: anObject

"Removes an identity clamp from the receiver for anObject.  Generates an error
 if there is no identity clamp on anObject."

idClamps == nil ifTrue: [self _errorNotFound: anObject. ^self]
               ifFalse: [^idClamps remove: anObject]
%

category: 'Identity Clamps'
method: ClampSpecification
removeAllIdClamps: aCollection

"Removes an identity clamp from the receiver for each object in aCollection.
 Does not generate an error if there is no identity clamp for any of the objects
 in aCollection."

idClamps ~~ nil
  ifTrue: [ idClamps _removeAll: aCollection errIfAbsent: false ]
%

category: 'Private'
method: ClampSpecification
_initializeClassClamps

"Initializes the class clamps variable.  Returns the receiver."

classClamps := ClassSet new.
%

category: 'Private'
method: ClampSpecification
_initializeIdClamps

"Initializes the identity clamps variable.  Returns the receiver."

idClamps := IdentitySet new.
%

category: 'Private'
method: ClampSpecification
_initializeInstVarLevels

"Initializes the instance variable levels variable.  Returns the receiver."

instVarLevels := FastIdentityKeyValueDictionary new.
instVarLevels keyConstraint: Class.
instVarLevels valueConstraint: Array.
%

! edited to fix 36715
category: 'Private'
method: ClampSpecification
_initIdClampsHolder: idc
classClamps: cc
instVarLevels: ivl
addSubleafHeaders: ash
traversalCallbackSelector: tcb

"Private."

idc _validateClass: IdentitySet .
idClamps := idc.
self
  addAllClassClamps: cc;
  addAllInstVarLevels: ivl;
  addSubleafHeaders: ash;
  traversalCallBackSelector: tcb
%

category: 'Initialization'
method: ClampSpecification
initialize

"Reset the state of the ClampSpecification to its initial state.
 Returns the receiver."

self nilFields.
^self
%

category: 'Initialization'
method: ClampSpecification
_initializeValueClamps

"Create a new value clamps set."

valueClamps := IdentitySet new.
%

category: 'Value Clamps'
method: ClampSpecification
includesValueClampFor: anObject

"Returns true if the receiver has value-clamped the given object.
 Returns false otherwise."

valueClamps == nil
  ifTrue:  [ ^ false ]
  ifFalse: [ ^ valueClamps includesIdentical: anObject ]
%

