!=========================================================================
! Copyright (C) VMware, Inc. 1986-2011.  All Rights Reserved.
!
! $Id: behavio.gs,v 1.32.2.1 2008-02-20 22:48:37 dhenrich Exp $
!
! Superclass Hierarchy:
!   Behavior, Object.
!
!=========================================================================

removeallmethods Behavior
removeallclassmethods Behavior

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

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

txt := (GsDocText new) details:
'Behavior is an abstract superclass with two concrete subclasses:
 Metaclass and Class.  You may not create any other subclasses of Behavior.

 Behavior describes the protocol common to all instances of Class
 and Metaclass.  In other words, you can send the messages listed
 here to any Class or Metaclass.  In the method descriptions below,
 "superclass" refers to the superclass of instances of the receiver,
 not to the superclass of the receiver itself.'.
doc documentClassWith: txt.

txt := (GsDocText new) details:
'The Behavior''s immediate superclass in the class hierarchy (a Metaclass).'.
doc documentInstVar: #superClass with: txt.

txt := (GsDocText new) details:
'A SmallInteger that encodes the following information in its bits:

 * (format \\ 4) = 0 if instances of the Behavior are pointer objects.
 * (format \\ 4) = 1 if instances of the Behavior are byte objects.
 * (format \\ 4) = 2 if instances of the Behavior are non-sequenceable
   collections (NSCs, such as Bags and Sets).
 * (format \\ 4) = 3 if instances of the Behavior are special objects.
 * ((format // 4) \\ 2) = 1 if instances of the Behavior are indexable.
 * ((format // 8) \\ 2) = 1 if instances of the Behavior are invariant.
 * ((format // 16) \\ 2) = 1 if the Behavior has constraints upon what can be
   stored in its instance variables.
 * ((format // 32) \\ 2) = 1 the Behavior does not allow subclass creation.
 * ((format // 128) \\ 2) = 1 the Behavior does not allow structural access
   from GemBuilder for C.'.
doc documentInstVar: #format with: txt.

txt := (GsDocText new) details:
'A SmallInteger telling the number of instance variables in instances of
 this class (including those inherited from superclasses).  Each instance
 of Behavior is limited to 255 named instance variables.'.
doc documentInstVar: #instVars with: txt.

txt := (GsDocText new) details:
'An invariant Array of Symbols giving the names of the Behavior''s instance
 variables, including those inherited from superclasses.  Each instance
 variable name is limited to 64 Characters, and must begin with an
 alphabetic character or an underscore ("_").  For more information, see
 the GemStone Programming Guide.'.
doc documentInstVar: #instVarNames with: txt.

txt := (GsDocText new) details:
'An invariant Array of Classes.  Each element in the Array is the class kind of
 a corresponding instance variable defined in a class or inherited from a
 superclass.'.
doc documentInstVar: #constraints with: txt.

txt := (GsDocText new) details:
'A SymbolDictionary used when compiling methods in this Behavior.  Each instance
 of a class has its own instance variables, which may differ in value.  Each
 class has its own class variables, which have the same value for all instances
 of the class.  For each SymbolAssociation in this dictionary, the key is a
 Symbol representing a class variable, and the corresponding value is the value
 of that class variable.  Each class variable name is limited to 64 Characters,
 and must begin with an alphabetic character or an underscore ("_").
 When resolving variable names, method compilation searches the classVars of 
 the class in which a method is being compiled, and also the classVars of superclasses. '.
doc documentInstVar: #classVars with: txt.

txt := (GsDocText new) details:
'A GsMethodDictionary that has all of the additional protocol (not inherited
 from superclasses) for instances of this Behavior.'.
doc documentInstVar: #methodDict with: txt.

txt := (GsDocText new) details:
'An Array of SymbolDictionaries used when compiling methods in this Behavior.
 The dictionaries contain objects that can be shared by multiple classes and
 multiple users.  When resolving variable names, method compilation searches 
 the poolDictionaries of the class in which a method is being compiled, but 
 does not search poolDictionaries of superclasses.'.
doc documentInstVar: #poolDictionaries with: txt.

txt := (GsDocText new) details:
'A GsMethodDictionary that categorizes selectors in this Behavior.  For each
 element in this dictionary, the key is a method category Symbol, and the
 corresponding value is a SymbolSet of the selectors for that method category.'.
doc documentInstVar: #categories with: txt.

txt := (GsDocText new) details:
'Reserved for future use by VMware, Inc.' .
doc documentInstVar: #secondarySuperclasses with: txt.

self description: doc.
%

category: 'Instance Creation'
classmethod: Behavior
new

"Disallowed.  To create a new Class or Metaclass, use
 Class | subclass:instVarNames:... instead."

self shouldNotImplement: #new
%

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

"Disallowed.  To create a new Class or Metaclass, use
 Class | subclass:instVarNames:... instead."

self shouldNotImplement: #new:
%

category: 'Testing Inheritance'
method: Behavior
isSubclassOf: aClassHistory

"Returns true if the receiver is identical to or is a subclass of any class
 in aClassHistory; otherwise, returns false.

 If the aClassHistory argument is actually a class rather than a class history,
 then this method uses the class history of the argument, instead of the class
 itself."

<primitive: 70>
self _primitiveFailed: #isSubclassOf: .
self _uncontinuableError
%

category: 'Testing Inheritance'
method: Behavior
validateSubclassOf: aClass

"Returns true if receiver is identical to aClass or is a subclass
 of aClass; otherwise, generates an error."

( self isSubclassOf: aClass) ifFalse:[
     ^ self _error: #rtErrNotASubclassOf args:#[aClass] ].
^ true
%

category: 'Testing Inheritance'
method: Behavior
_validateSubConstraintOf: aClass

"Returns true if receiver is identical to aClass or is a subclass of aClass,
 otherwise generates an error with message specific to class modification."

( self isSubclassOf: aClass) ifFalse:[
     ^ self _error: #rtErrConstrNotSubclassOf args:#[aClass] ].
^ true
%

category: 'Testing'
method: Behavior
isBehavior

"Returns true if the receiver is a kind of Behavior, and returns false
 otherwise."

  ^true
%

! fix bug 6601
category: 'Accessing the Class Format'
method: Behavior
isNonByteVarying

"Returns true if the instances of the receiver are not byte objects and have
 unnamed instance variables; returns false otherwise."

| bits |

bits := format bitAnd: 7.
^bits == 2 _or: [bits == 4].
%

category: 'Private Methods for Class Modification'
method: Behavior
_namedIvConstraintAtOffset: offset

"Returns the constraint, if any, on the named instance variable at the
 specified offset.  Returns Object if there is no such named instance variable,
 or if the instance variable at that offset is not constrained."

(offset > instVars) ifTrue:[ ^ Object ] .
^ constraints at: offset
%

category: 'Private Methods for Class Modification'
method: Behavior
_insertNamedInstVar: aSymbol atOffset: offset

"Receiver and all subclasses must have be modifiable.  aSymbol must be unique
 with respect to existing instance variables."

" add instance variable to self"
|mySubclasses|

self _validatePrivilege.
instVarNames insertObject: aSymbol at: offset .
constraints  insertObject: Object  at: offset .
self _incrementInstVars .
self _refreshClassCache .
mySubclasses := self _subclasses .
mySubclasses ~~ nil ifTrue:[
  mySubclasses do:[:x | x _insertNamedInstVar: aSymbol atOffset: offset ].
  ].
^ self
%

category: 'Private Methods for Class Modification'
method: Behavior
_incrementInstVars

"Increment instVars by 1 to account for adding a named instance variable."

self _validatePrivilege.
instVars := instVars + 1 
%

category: 'Private Methods for Class Modification'
method: Behavior
_makeProtected

"Make the receiver a protected class by setting a bit in its format.  This
 protection disallows structural access through GemBuilder for C."

self _validatePrivilege.
format := format bitOr: 128 
%

category: 'Private Methods for Class Modification'
method: Behavior
_newConstraint: aClass atOffset: offset 

"Execute the constraint change for Behavior | instvar:ConstraintTo:
 assuming all error and variance checks have been done."

self _validatePrivilege.
constraints at: offset put: aClass .
(aClass == Object) ifFalse:[ self _setConstraintBit ].
self _refreshClassCache .
%

category: 'Private Methods for Class Modification'
method: Behavior
_recompileMethodsAfterNewIvOffset: newOffset

""

| mySymList mySubclasses |
self _validatePrivilege.
mySymList:= System myUserProfile symbolList .
(newOffset < instVars) ifTrue:[
    self recompileAllMethodsInContext: mySymList ] .
mySubclasses := self _subclasses .
mySubclasses ~~ nil ifTrue:[
  mySubclasses do:[:x | x _recompileMethodsAfterNewIvOffset: newOffset ] .
  ].
^ self
%

category: 'Private Methods for Class Modification'
method: Behavior
_refreshClassCache

"Clears and optionally reloads the object manager class cache.
 Must be sent immediately after any change to the constraints ,  
 format or named instance variables of the receiver."

<primitive: 227>
self _primitiveFailed:#_refreshClassCache .
self _uncontinuableError
%

category: 'Private Methods for Class Modification'
method: Behavior
_removeInstVarAtOffset: offset

"Remove named instance variable at specified offset from self and all
 subclasses assuming that all error checks have been done."

self _validatePrivilege.
instVarNames removeFrom: offset to: offset .
constraints removeFrom: offset to: offset .
instVars := instVars - 1 .
self _refreshClassCache .
self _subclasses do:[:x| x _removeInstVarAtOffset: offset ] .
^ self
%

category: 'Private Methods for Class Modification'
method: Behavior
_setConstraintBit

"Sets the constraint bit in the 'format' instance variable of the receiver."

self _validatePrivilege.
format := format bitOr: 16#10 .
%

category: 'Private Methods for Class Modification'
method: Behavior
_disallowGciCreateStore

"Private.

 Sets bit in the format instance variable to cause GemBuilder for C instance
 creation and updates to go through message sends.  Semantics are private to
 GemBuilder for Smalltalk."

self _validatePrivilege.
format := format bitOr: 16r200 "no update through structural access" .
self _refreshClassCache
%

category: 'Private'
method: Behavior
_structuralUpdatesDisallowed

"Private.

 Returns true if GemBuilder for C (GCI) direct structural update of instances
 is disallowed, false otherwise.  A result of true means that the deferred
 update mechanism is used (see GciProcessDeferredUpdates in gci.hf) by
 GemBuilder for C store operations on instances of the receiver."

self _validatePrivilege.
^ (format bitAnd: 16r200 "no update through structural access") ~~ 0
%

category: 'Private'
method: Behavior
_traversalByCallback

"Private.

 Returns true if GemBuilder for C (GCI) traversal results of instances 
 are obtained by message send of aClampSpecification.traversalCallBackSelector,
 false otherwise."

^ (format bitAnd: 16r400"travByCallback") ~~ 0 
%

category: 'Private'
method: Behavior
_makeTraversalByCallback

"Private.

 Make the receiver place its instances in a traversal buffer by
 invoking the clampSpecification's traversal callback method."

self _validatePrivilege.
format := format bitOr: 16r400. "travByCallback"
self _refreshClassCache.
%

category: 'Private Methods for Class Modification'
method: Behavior
_validateNewVaryingConstraint: aClass

"aClass is the proposed new constraint on unnamed instance variables.  If
 aClass is not a superclass of the already existing constraint, then check to
 ensure that the receiver is modifiable.  Recursively check all subclasses."

(self varyingConstraint isSubclassOf: aClass) ifFalse:[
  self validateIsModifiable.
  self _subclasses do:[:x| x _validateNewVaryingConstraint: aClass].
  ] .
%

category: 'Private Methods for Class Modification'
method: Behavior
_validateNewInheritedConstraint: aClass atOffset: offset

"If the current constraint is not a subclass of the new constraint, checks to
 ensure that the receiver is modifiable.  Recursively checks subclasses."

((constraints at: offset) isSubclassOf: aClass ) ifFalse:[
   self validateIsModifiable .
   self _subclasses do:[:x|
      x _validateNewInheritedConstraint: aClass atOffset: offset
      ] .
   ] .
^ self
%

category: 'Private Methods for Class Modification'
method: Behavior
_updateVaryingConstraint: aClass

"Update the receiver's constraint on unnamed variables to be consistent with
 inheritance rules, where aClass is the new constraint which has been placed on
 the superclass's unnamed part.  Recursively update subclasses.  Checks to
 ensure self and subclasses are modifiable must have already been made."

self _validatePrivilege.
(self varyingConstraint isSubclassOf: aClass) ifFalse:[
    self _setVaryingConstraint: aClass .
    self _subclasses do:[:x| x _updateVaryingConstraint: aClass].
    ] .
%

category: 'Private Methods for Class Modification'
method: Behavior
_newInheritedConstraint: aClass atOffset: offset

"Change the constraint for offset to aClass if that offset is not
 already constrained to be a subclass of aClass.  Assume all
 variance and error checks have been done."

self _validatePrivilege.
((constraints at: offset) isSubclassOf: aClass ) ifFalse:[
    self _newConstraint: aClass atOffset: offset .
    self _subclasses do:[:aSubcls|
       aSubcls _newInheritedConstraint: aClass atOffset: offset ].
    ] .
%

category: 'Private Methods for Class Modification'
method: Behavior
_validateNewNamedInstVar: aSymbol

"Generate an error if the argument is the name of an already existing instance
 variable of the receiver or if the receiver is not modifiable and has not
 disallowed subclassing."

| mySubclasses |

"reimplementation of self validateIsModifiable ."
self isModifiable ifFalse:[
   self isNsc ifTrue:[^ self _error: #rtErrClassNotModifiable].
   self subclassesDisallowed ifFalse:[^ self _error: #rtErrClassNotModifiable] .
   self isIndexable ifTrue:[ ^ self _error: #rtErrClassNotModifiable ]
   ] .

(instVarNames includesValue: aSymbol)
   ifTrue:[ ^ self _error: #rtErrAddDupInstvar args:#[ aSymbol ] ].
mySubclasses := self _subclasses .
mySubclasses ~~ nil ifTrue:[
  mySubclasses do:[:aSubCls| aSubCls _validateNewNamedInstVar: aSymbol ] .
  ].
^ self
%

category: 'Private Methods for Class Modification'
method: Behavior
_setVaryingConstraint: aClass

"Assign a new value to the constraint on unnamed variables of the receiver,
 assuming all checks have been made."

self _validatePrivilege.
constraints at:(instVars + 1) put: aClass .
(aClass == Object) ifFalse:[ self _setConstraintBit ].
self _refreshClassCache .
^ self
%

category: 'Error Handling'
method: Behavior
_isInstanceDisallowed

""

^ (InstancesDisallowed includesValue: self) _or: [self isKindOf: Metaclass]
%

category: 'Updating the Method Dictionary'
method: Behavior
removeAllMethods

"Removes all methods from the receiver.  This should not be done without
 considerable forethought!"

self _validatePrivilege.
categories ~~ nil ifTrue: [ categories removeAll ].
methodDict ~~ nil ifTrue: [ methodDict removeAll ].
self _refreshClassCache.
%

category: 'Updating the Method Dictionary'
method: Behavior
_basicRemoveSelector: aSymbol

"Private."
| oldMeth |

self _validatePrivilege.
oldMeth := methodDict removeKey: aSymbol . "runtime error here if key not found"

"refresh method lookup caches to account for removal of the selector
 and delete any breakpoints in the removed method ."
self _refreshLookupCache: aSymbol oldMethod: oldMeth.  
%

category: 'Updating the Method Dictionary'
method: Behavior
removeSelector: aString

"Removes the method whose selector is aString from the receiver's method
 dictionary.  If the selector is not in the method dictionary, generates an
 error.  Any breakpoints in the removed method are cleared.
"

| selector |

self _validatePrivilege.
self _basicRemoveSelector: (selector := aString asSymbol) .
categories associationsDo: [:anAssoc | | setOfSelectors |
  setOfSelectors:= anAssoc value.
  (setOfSelectors remove: selector ifAbsent:[ nil ]) ~~ nil ifTrue:[ 
    ^ self "done"
    ]
  ].

"if we get here , we could not find the selector in any category "
^ self _error: #classErrSelectorNotFound args: #[aString] .
%

category: 'Backward Compatibility'
method: Behavior
_compileMethod: sourceString
dictionaries: aSymbolList
category: categorySymbol

^ self compileMethod: sourceString dictionaries: aSymbolList
    category: categorySymbol intoMethodDict: nil intoCategories: nil
    intoPragmas: nil .
%

category: 'Updating the Method Dictionary'
method: Behavior
compileMethod: sourceString
dictionaries: aSymbolList
category: categorySymbol
intoMethodDict: aMethodDict
intoCategories: aCategDict
intoPragmas: aPragmasArray

"Compiles sourceString as a method for the receiver in category categorySymbol,
 using the symbol list aSymbolList.  If the compilation succeeds, returns the
 GsMethod produced by the compilation.  If the compilation fails, returns
 an Array of error descriptors.

 The Array of error descriptors is as described for the
 compileMethod:dictionaries:category: method.

 If aMethodDict is not nil, and the compilation succeedd,
 the resulting method is added to aMethodDict instead of to 
 the receiver's method dictionary.  This is used to add methods 
 to per-session dictionaries.

 pragmasArray must be nil, or an instance of Array. If compilation
 is successful and pragmasArray is not nil, any pragmas found by the 
 compiler are appended (as selector, Array pairs) to pragmasArray .

 The caller is responsible for setting the current Segment to
 match the receiver's Segment if desired.

 You must have code modification privilege to execute this method.
 "

| result errorArray errDict |
"Get a GsMethod or an Array of warnings and error info."
result := self _primitiveCompileMethod: sourceString
		symbolList: aSymbolList category: categorySymbol 
             oldLitVars: nil intoMethodDict: aMethodDict intoCategories: aCategDict 
		intoPragmas: aPragmasArray .
           
result _class == GsMethod ifTrue:[
  ^ result
  ]
ifFalse:[
  errorArray := result at: 2 .
  errorArray == nil ifTrue: [ "Warning, so return GsMethod" ^result at: 1 ].
  "Fill in the error message text for each error in the result."
  errDict := GemStoneError at: System myUserProfile nativeLanguage .
  1 to: errorArray size do:[:j | | thisErr errNum |
    thisErr := errorArray at: j .
    (thisErr size < 3  _or:[ nil == (thisErr at: 3)]) ifTrue:[
      errNum := thisErr at: 1 .
      errNum > errDict size 
        ifTrue:[ thisErr at: 3 put: '(unknown error number)']
        ifFalse:[ thisErr at: 3 put: (errDict at: errNum) asString ].
      ]
    ]. 
  ^ errorArray .
  ].
%

category: 'Private'
method: Behavior
_primitiveCompileMethod: sourceString
symbolList: aSymbolList
category: categorySymbol
oldLitVars: litVarArray
intoMethodDict: aMethodDict
intoCategories: aCategDict
intoPragmas: pragmasArray

"Compiles sourceString as a method for the receiver in category categorySymbol,
 using the symbol list aSymbolList.  If the compilation succeeds, the method
 dictionary of the receiver will have been updated.

 Returns the GsMethod produced by the compilation if the compilation 
 succeeded with no warnings or errors, or an Array of of the form
    #[ (GsMethod or nil if the compilation has errors) ,
       (nil or an Array of error descriptors as described for 
        compileMethod:dictionaries:category: ) ,
       (nil or a String describing warnings) 
     ] .
      
 If litVarArray is not nil, it must be an Array of SymbolAssociations;
 which will be used instead of doing a symbolList lookup to
 resolve literal variables within the method.  This argument must
 be nil in this version; it will be used in Gs64 v3.0 for recompilation
 of methods.

 If litVarArray is nil, a literal variable is resolved by
 searching the pool dictionaries, class variables and, if
 aSymbolList is not nil, search aSymbolList.  

 If aMethodDict is not nil, and the compilation succeeds,
 the resulting method is added to aMethodDict instead of to 
 the receiver's method dictionary.  This is used to add methods 
 to per-session dictionaries.
  
 If aMethodDict is not nil and aCategDict is not nil and
 the compilation succeeds, the resulting method is added aCategDict
 instead of the receiver's categories.

 pragmasArray must be nil, or an instance of Array. If compilation
 is successful and pragmasArray is not nil, any pragmas found by the 
 compiler are appended (as selector, Array pairs) to pragmasArray .

 If the compilation succeeds, the selector of the new method is
 removed from all method lookup caches for the receiver and all subclasses
 thereof,   independent of the value of aMethodDict argument.

 You must have code modification privilege to execute this primitive.
"

<primitive: 228>
sourceString _validateClasses: #[String, DoubleByteString].
aSymbolList ~~ nil  ifTrue:[ aSymbolList _validateClass: SymbolList ].
categorySymbol _validateClass: Symbol.
litVarArray ~~ nil ifTrue:[ litVarArray _validateClass: Array].
aMethodDict ~~ nil ifTrue:[ aMethodDict _validateClass: GsMethodDictionary ].
aCategDict ~~ nil ifTrue:[ aCategDict _validateClass: GsMethodDictionary ].
pragmasArray ~~ nil ifTrue:[ pragmasArray _validateClass: Array].

^ self _primitiveFailed: 
  #_primitiveCompileMethod:symbolList:category:oldLitVars:intoMethodDict:intoCategories:intoPragmas:
%

! fix 7154
category: 'Updating the Method Dictionary'
method: Behavior
compileMethod: sourceString
dictionaries: aSymbolList
category: aCategoryString

"This compiles some source code for the receiver.  The first argument,
 sourceString, is the string of source code to be compiled.  The second
 argument is a SymbolList to be used in parsing, along with the list of all
 class variables and pool dictionaries for the receiver and all of its
 superclasses.  The third argument (a String) indicates the method's category.

 sourceString must be a kind of String or DoubleByteString.  Instances of
 JapaneseString are not supported as source strings.  String literals
 ('abc') are generated as instances of the class of sourceString, 
 unless sourceString is a Symbol, in which case 'abc' produces a String.
 If sourceString is a DoubleByteSymbol, 'abc' produces a DoubleByteString.

 If there are no errors, this adds the resulting compiled method to the
 receiver's method dictionary and returns nil.

 If errors occur, the result is an Array of error descriptors which can be
 be used as an input to the GsMethod (C) | _sourceWithErrors:fromString: 
 method.
 
 An error descriptor is an Array of size 3 or 4, containing the following
 elements:

 1. The GemStone error number.
 2. Offset into the source string where the error occurred.
 3. Error message text, if available, or nil.
 4. Internal compiler error text, if the error is internal."

| symList categ result |

self _validatePrivilege.
aSymbolList class == SymbolList
  ifTrue:[ symList := aSymbolList ]
  ifFalse:[
    aSymbolList _validateClass: Array .
    symList := SymbolList withAll: aSymbolList .
    ] .
categ := aCategoryString asSymbol .

Segment setCurrent: self segment while:[
  result := self compileMethod: sourceString
       dictionaries: symList
       category: categ  intoMethodDict: nil intoCategories: nil
       intoPragmas: nil .

  result _class == GsMethod ifTrue:[ result := nil ].
].
^ result
%

category: 'Updating the Method Dictionary'
method: Behavior
compileAccessingMethodsFor: anArrayOfSymbols

"This method is a simple way to create methods for reading and modifying
 instance variables in instances of the receiver.  Each element of
 anArrayOfSymbols must be an instance variable in the receiver.  For each
 instance variable 'x' in the Array, two methods are created: 'x' (read the
 variable) and 'x:newValue' (modify the variable).  The first method ('x') is
 placed in the category 'Accessing', while the second method ('x:newValue') is
 placed in the category 'Updating'.

 The method can also be used to create methods for accessing and modifying
 class and pool variables.  When creating class methods, the message must be
 sent to the class of the class.

 Returns the receiver.  Generates an error if any element of anArrayOfSymbols
 is not an instance variable, class variable, or pool variable of the
 receiver."

| newLine accessing updating allVarNames varName |

self _validatePrivilege.
accessing := Symbol withAll: 'Accessing'.
updating := Symbol withAll: 'Updating'.
varName := 'newValue'.
allVarNames := self allInstVarNames.
[allVarNames includesValue: varName] whileTrue: [
  varName := 'z' , varName.
].
newLine:= Character lf asString.
anArrayOfSymbols do:
    [ :var |
      (self compileMethod: (var , newLine , newLine ,
            '   "Return the value of the instance variable ''' , var ,
            '''."' , newLine , '   ^' , var , newLine)
            dictionaries:  #() 
            category: accessing) == nil
      ifFalse:
        [^ self _error: #classErrNotAVar args: #[var]].

      (self compileMethod: (var , ': ' , varName , newLine , newLine ,
            '   "Modify the value of the instance variable ''' , var ,
            '''."' , newLine , '   ' , var , ' := ' , varName , newLine)
            dictionaries:  #() 
            category: updating) == nil
      ifFalse:
        [^ self _error: #classErrNotAVar args: #[var]].
    ]
%

! _setMessageBreak: deleted

category: 'Debugging Support'
method: Behavior
_setMethodBreak: aSelector stepPoint: anInt

"Returns true to indicate success.  Otherwise it returns a string describing
 the error."

  | method selectorSym |

  (aSelector isByteKindOf: CharacterCollection)
  ifFalse:
    [ ^ 'Illegal selector' ].
  selectorSym := aSelector asSymbol .

  (#( ifFalse:  ifFalse:ifTrue:   _and:   _or: 
     ifTrue:   ifTrue:ifFalse:   timesRepeat:   to:by:do: 
     to:do:   untilFalse   untilTrue   whileFalse:   whileTrue:   
     #==   #~~   isKindOf:   _class   _disableProtectedMode 
     _gsReturnNoResult _gsReturnTos _gsReturnNothingEnableEvents 
     _isInteger _isSmallInteger _isSymbol )
    includesIdentical: aSelector)
  ifTrue:
     [ ^ 'You may not set a method break on an optimized selector' ].

  (self == SmallInteger 
      _and: [ #(  #+  #-  #>=  #*  #=  ) includesIdentical: aSelector])
  ifTrue:
    [ ^ 'You may not set a method break on an optimized selector' ].

  (anInt _isSmallInteger)
  ifFalse:
    [ ^ 'Step point must be a SmallInteger' ].
  (self includesSelector: aSelector)
  ifFalse:
    [ ^ 'Selector does not exist in class' ].
  method := self compiledMethodAt: aSelector.
  (anInt >= 1) & (anInt <= method _ipSteps size)
  ifFalse:
    [ ^ 'Step point does not exist in method' ].

  (self compiledMethodAt: aSelector ) setBreakAtStepPoint: anInt .

  ^ true
%

! _messageBreakObject: deleted

! _methodBreakObject:stepPoint: deleted


category: 'Debugging Support'
method: Behavior
_sourceCodeAndOffsets: aSelector

"Returns an Array with two elements.  The first element is a String
 representing the source code for the argument, aSelector.  The second element
 is an InvariantArray (that holds SmallIntegers) is a list of offsets into
 sourceString, corresponding in order to the step points.  If aSelector (a
 String) is not a selector in the receiver's method dictionary, returns nil."

| method anArray |

((method := methodDict at: (aSelector asSymbol)) ~~ nil)
ifTrue:
   [ anArray := Array new: 2.
     anArray at: 1 put: (method _sourceString);
             at: 2 put: (method _sourceOffsets).
     ^ anArray
   ]
ifFalse:
   [ ^ nil ]
%

category: 'Accessing the Class Hierarchy'
method: Behavior
allSuperClasses

"Returns an Array of the superclasses of the receiver, beginning
 with the immediate superclass, and excluding the receiver."

| result currClass |
result:= Array new.
(superClass == nil)
  ifTrue: [^ result]
  ifFalse: [
    currClass := self superClass.
    [ currClass == nil ] whileFalse: [
      result add: currClass.
      currClass := currClass superClass.
    ].
  ].
^result
%

category: 'Accessing the Class Hierarchy'
method: Behavior
_allSuperList

"Returns an Array of the superclasses of the receiver, beginning
 with the most remote superclass, and excluding the receiver itself."

| result currClass |

result:= Array new.
(superClass == nil)
ifTrue:
   [^ result]
ifFalse:
   [ currClass:= self superClass.
     [ currClass == nil ]
     whileFalse:
     [ result insertObject: currClass at: 1.
       currClass:= currClass superClass.
     ].
   ].
^ result
%

category: 'Accessing the Class Hierarchy'
method: Behavior
inheritsFrom: aClass

"Returns true if the argument aClass is on the receiver's
 superclass chain; returns false if it isn't."


(aClass isKindOf: Behavior)
ifFalse:
   [self _error: #rtErrBadArgKind args: #[Class]].

(self isSubclassOf: aClass)
   ifTrue: [
     self == aClass
       ifTrue: [^false]
       ifFalse: [^true]
   ]
   ifFalse: [^false] .
   self _uncontinuableError " should never get here"
%

category: 'Accessing the Class Hierarchy'
method: Behavior
superClass

"Returns the receiver's superclass."

^superClass
%

category: 'Updating Categories'
method: Behavior
addCategory: aString

| aSymbol |
"Adds aString as a method category for the receiver.  If aString is already a
 method category, generates an error."

self _validatePrivilege.
aSymbol := aString asSymbol .
(categories includesKey: aSymbol)
ifTrue:[ ^ self _error: #classErrMethCatExists
                  args: #[aString, self]] "category already exists for class"
ifFalse:
   [categories add: (SymbolAssociation newWithKey: aSymbol
                                       value: SymbolSet new ) ]
%

category: 'Updating Categories'
method: Behavior
moveMethod: aSelector toCategory: categoryName

"Moves the method aSelector (a String) from its current category to the
 specified category (also a String).  If either aSelector or categoryName is
 not in the receiver's method dictionary, or if aSelector is already in
 categoryName, generates an error."

| theKeys   "Array of keys of dictionary categories"
  index     "loop index"
  oldCateg    "SymbolSet of selectors of original category"
  newCateg    "SymbolSet of selectors of new category"
  theSize   "size of theKeys"
  selectorSym 
|

"this method does not account for selectors inherited from superclasses"

self _validatePrivilege.
newCateg:= categories at: categoryName asSymbol .

theKeys:= (Array withAll: (categories keys)).
theSize := theKeys size.
selectorSym := aSelector asSymbol .
index:= 1.  "find original category of aSelector"

[((oldCateg:= (categories at: (theKeys at: index)))
                            includesValue: selectorSym )
  _or: [index >= theSize]
]
whileFalse:
   [index := index + 1].

(oldCateg includesValue: selectorSym ) 
  ifTrue: [ oldCateg remove: selectorSym ]
 ifFalse: [ ^ self _error: #classErrSelectorNotFound args: #[selectorSym] ].

(newCateg includesValue: selectorSym) "add aSelector"
ifTrue: [
  "selector already there, unlikely"
  self _uncontinuableError .
  ]
ifFalse: [newCateg add: selectorSym]
%

category: 'Updating Categories'
method: Behavior
removeCategory: categoryName

"Removes the specified category and all its methods from the receiver's
 method dictionary.  If categoryName is not in the receiver's method
 dictionary, generates an error.
 Any breakpoints in removed methods are cleared."

| theSelectors |

self _validatePrivilege.
theSelectors := categories at: (categoryName asSymbol).
1 to: theSelectors size do: [ :each |
  self _basicRemoveSelector: (theSelectors at: each)
  ].
categories removeKey: (categoryName asSymbol)
           ifAbsent: [ ^ self _error: #classErrMethCatNotFound
                              args: #[categoryName]]
%

category: 'Updating Categories'
method: Behavior
renameCategory: categoryName to: newCategoryName

"Changes the name of the specified category to newCategoryName (a
 String), and returns the receiver.  If categoryName is not in the
 receiver's method dictionary, or if newCategoryName is already in the
 receiver's method dictionary, generates an error."

self _validatePrivilege.
(categories includesKey: (newCategoryName asSymbol))
ifTrue: [^ self _error: #classErrMethCatExists args: #[newCategoryName, self]].

(categories includesKey: (categoryName asSymbol))
ifTrue: [
   categories add: (SymbolAssociation newWithKey: (newCategoryName asSymbol)
                                      value: (categories at: categoryName)).
   categories removeKey: categoryName
   ]
ifFalse: [
   "key not found"
   ^ self _error: #classErrMethCatNotFound
            args: #[categoryName]
   ]
%

category: 'Accessing the Method Dictionary'
method: Behavior
allSelectors

"Returns an Array of Symbols, consisting of all of the message
 selectors that instances of the receiver can understand, including
 those inherited from superclasses.  For keyword messages, the
 Symbol includes each of the keywords, concatenated together."

| result currClass |

(superClass == nil)
ifTrue:
   [^ self selectors]
ifFalse:
   [ result:= Array new.
     currClass:= self.
     [ currClass == nil ]
     whileFalse:
     [ result insert: (currClass selectors) at: 1.
       currClass:= currClass superClass.
     ].
   ].
^ result
%

category: 'Accessing the Method Dictionary'
method: Behavior
canUnderstand: aSelector

"Returns true if the receiver can respond to the message indicated by
 aSelector, returns false otherwise.  The selector (a String) can be in the
 method dictionary of the receiver or any of the receiver's superclasses."

| aSymbol |
aSymbol := Symbol _existingWithAll: aSelector .
aSymbol == nil ifTrue:[ ^ false ].

((self whichClassIncludesSelector: aSymbol) ~~ nil)
ifTrue:
   [^ true].
^false
%

category: 'Accessing the Method Dictionary'
method: Behavior
compiledMethodAt: aSelector

"Returns the compiled method associated with the argument aSelector (a String).
 The argument must be a selector in the receiver's method dictionary; if it is
 not, this method generates an error."

| aSym |
aSym := Symbol _existingWithAll: aSelector.
aSym == nil ifTrue:[ ^ methodDict _errorKeyNotFound: aSelector ].
^ methodDict at: aSym
%


category: 'Accessing the Method Dictionary'
method: Behavior
includesSelector: aString

"Returns true if the receiver defines a method for responding to aString."

| aSym |
aSym := Symbol _existingWithAll: aString.
aSym == nil ifTrue:[ ^ false ].
^ methodDict includesKey: aSym 
%

category: 'Accessing the Method Dictionary'
method: Behavior
selectors

"Returns an Array of Symbols, consisting of all of the message selectors
 defined by the receiver.  (Selectors inherited from superclasses are not
 included.)  For keyword messages, the Symbol includes each of the keywords,
 concatenated together."

^ Array withAll: (methodDict keys)
%

category: 'Accessing the Method Dictionary'
method: Behavior
sourceCodeAt: aSelector

"Returns a String representing the source code for the argument, aSelector.  If
 aSelector (a String) is not a selector in the receiver's method dictionary,
 this generates an error."

|method aSym|

aSym := Symbol _existingWithAll: aSelector.
aSym == nil ifTrue:[ ^ methodDict _errorKeyNotFound: aSelector ].
((method:= methodDict at: aSym ) ~~ nil)
ifTrue:
   [^ method _sourceString]
ifFalse:
   [^ nil]
%

category: 'Accessing the Method Dictionary'
method: Behavior
_methodDict

"Returns the method dictionary."

^ methodDict
%

category: 'Accessing the Method Dictionary'
method: Behavior
_implementor: aString

""
^ self whichClassIncludesSelector: aString
%

category: 'Accessing the Method Dictionary'
method: Behavior
whichClassIncludesSelector: aString

"If the selector aString is in the receiver's method dictionary,
 returns the receiver.  Otherwise, returns the most immediate superclass
 of the receiver where aString is found as a message selector.  Returns
 nil if the selector is not in the method dictionary of the receiver or
 any of its superclasses."

  | currClass aSymbol |
  aSymbol := Symbol _existingWithAll: aString .
  aSymbol == nil ifTrue:[ ^ nil ].

  "Check the immediate class directly"
  (methodDict includesKey: aSymbol) ifTrue: [^self].

  "Okay, check the superclasses"
  currClass := superClass.

  [ currClass == nil ifTrue: [^nil].
    currClass _methodDict includesKey: aSymbol]
  whileFalse:
    [ currClass := currClass superClass ].

  ^currClass
%

category: 'Virtual Machine Control'
method: Behavior
_refreshLookupCache: aSelector oldMethod: aMethod

"This method remove entries for aSelector from the method lookup cache for the
 receiver.  This message must be sent whenever a class's method dictionary
 changes, to keep the caches current.

 If the argument aMethod is not nil, any breakpoints in aMethod are cleared.
"

<primitive: 374>
self _primitiveFailed: #_refreshLookupCache:oldMethod: .
self _uncontinuableError
%

! fix bug 13023
category: 'Browser Methods'
method: Behavior
_addCategory: categoryName

"Returns the Array representing the new category."

self _validatePrivilege.
self addCategory: categoryName .
^ categories at: categoryName asSymbol
%

category: 'Browser Methods'
method: Behavior
_poolDictionaries

"Returns the object containing this instance's pool dictionaries."

^ poolDictionaries
%

category: 'Browser Methods'
method: Behavior
_categories

"Returns the GsMethodDictionary containing this instance's category
 organization."

^ categories
%
category: 'Browser Methods'
method: Behavior
_categoriesReport

"Returns an Array containing key-value pairs from the receiver's categories.
 The key in each key-value pair is the name of a category; the value in each
 key-value pair is a sorted Array of selectors."

"Used by the Topaz 'list categories' command."

| result assocs anAssoc k |
assocs := IdentitySet new .
categories keysAndValuesDo:[:categName :selectors| | sortedSelectors |
  sortedSelectors := SortedCollection new .
  selectors do:[:aSelector| sortedSelectors add: aSelector ].
  sortedSelectors := Array withAll: sortedSelectors .
  assocs add: (SymbolAssociation newWithKey: categName value: sortedSelectors) 
  ].
assocs := assocs sortAscending: 'key' .
result := Array new: assocs size * 2  .
k := 1 .
1 to: assocs size do:[:j | 
 anAssoc := assocs at: j . 
 result at: k put: anAssoc key .
 result at: k + 1 put: anAssoc value .
 k := k + 2 .
 ].
^ result .
%

! _selectorsAndSourceStrings deleted

! fix bug 13026
category: 'Browser Methods'
method: Behavior
_selectorWithSource: aString

"Returns the selector for the method whose source string is identical to
 aString."

methodDict keysAndValuesDo:[:aSelector :aMethod |
  (aMethod _sourceString == aString) ifTrue: [^ aSelector ]
  ].
^nil
%

! remove _sourceCodeDictionaryForCategory: 

! _sourceCodeStringsForCategory: deleted

category: 'Accessing Variables'
method: Behavior
allClassVarNames

"Returns an Array of Symbols, consisting of the names of the class
 variables addressable by this class, including those inherited
 from superclasses.  Contrast with classVarNames."

| result currClass |

result:= Array new.
currClass:= self.
[ currClass == nil ]
whileFalse:
[ result insert: (currClass classVarNames) at: 1.
  currClass:= currClass superClass
].

^ result
%

category: 'Accessing Variables'
method: Behavior
allInstVarNames

"Returns an Array of Symbols, consisting of the names of all the receiver's
 instance variables, including those inherited from superclasses.  The ordering
 of the names in the Array follows the ordering of the superclass hierarchy;
 that is, instance variable names inherited from Object are listed first, and
 those peculiar to the receiver are last."

^ Array withAll: instVarNames
%

category: 'Accessing Variables'
method: Behavior
allSharedPools

"Returns an Array of pool dictionaries used by this class and its superclasses.
 Contrast with sharedPools."

| result currClass |

result:= Array new.
currClass:= self.
[ currClass == nil ]
whileFalse:
[ result insert: (currClass sharedPools) at: 1.
  currClass:= currClass superClass
].

^ result
%

category: 'Accessing Variables'
method: Behavior
classVarNames

"Returns an Array of Symbols naming the class variables defined by this class.
 Inherited class variables are not included; contrast with allClassVarNames."

| result |

result:= Array new.
(classVars == nil)
ifTrue:
   [^ result]
ifFalse:
[
   (classVars keys) do: "get them from the dictionary"
       [:each| result add: each].
    ^ result
]
%

category: 'Accessing Variables'
method: Behavior
_classVars

"Returns the classVars instance variable."

^ classVars
%

category: 'Accessing Variables'
method: Behavior
classVarAt: aClassVar

"Returns the value of the class variable aClassVar."

^ classVars at: aClassVar asSymbol.
%

category: 'Accessing Variables'
method: Behavior
instVarNames

"Returns an Array of Symbols naming the instance variables defined by the
 receiver, but not including those inherited from superclasses.  Contrast
 with allInstVarNames."

| inheritedInstVars "an Array of the inherited instance variables"
  size              "the size of inherited instance variables"
  myInstVars        "an Array of all of the instance variables"  |

myInstVars := instVarNames.
superClass == nil ifTrue:
  [ ^myInstVars ].

inheritedInstVars := superClass _instVarNames.
(size := inheritedInstVars size) == myInstVars size ifTrue:
  [ ^#[] ].

"Assume that each inherited instance variable is added to the end of
 the Array result of allInstVarNames."

^#[] addAll: (myInstVars copyFrom: size + 1 to: myInstVars size).
%

category: 'Accessing Variables'
method: Behavior
scopeHas: aVariableName
ifTrue: aBlock

"If aVariableName (a String) is specified as a variable in the receiver or one
 of its superclasses, this evaluates the zero-argument block aBlock and returns
 the result of evaluating aBlock.  Otherwise, returns false."

| allSharedPools |

(aVariableName isKindOf: String)
ifFalse:
   [ ^ aVariableName _error: #rtErrBadArgKind args: #[String]].

( ((self allInstVarNames ) includesValue: aVariableName) _or:
 [((self allClassVarNames) includesValue: aVariableName)])
ifTrue:
   [^ aBlock value]
ifFalse: "now check sharedPools"
[
   allSharedPools:= self allSharedPools.
   allSharedPools do: [:poolDict |
                         (poolDict includesKey: aVariableName)
                         ifTrue:
                            [ ^ aBlock value]
                      ]
].
^ false
%

category: 'Accessing Variables'
method: Behavior
sharedPools

"Returns an Array of pool dictionaries used by this class.  Superclasses
 are not included; contrast with allSharedPools."

^ Array withAll: poolDictionaries
%

category: 'Accessing Variables'
method: Behavior
constraintOfInstVar: aString

"Returns the constraint on the instance variable named aString for instances
 of the receiver.  Generates an error if aString is not the name of an instance
 variable defined by the receiver."

| aSym offArray |
aSym := Symbol _existingWithAll: aString .
aSym ~~ nil ifTrue:[
  offArray := self _ivOffsetAndConstraint: aSym .
  offArray ~~ nil ifTrue:[
    ^ offArray at: 2 .
    ].
  ].
^ self _errorInvalidOffset: aString .
%

category: 'Accessing the Class Format'
method: Behavior
format

"Returns the value of the format instance variable."

^ format
%

category: 'Accessing the Class Format'
method: Behavior
implementationFormat

"Returns the three least-significant bits of the receiver's format instance
 variable.  The values of those bits mean the following:

 0   OOP       non-indexable
 1   Byte      non-indexable
 2   NSC       non-indexable
 3   Special   non-indexable
 4   OOP       indexable
 5   Byte      indexable"

^ format \\ 8
%

category: 'Accessing the Class Format'
method: Behavior
instSize

"Returns the number of named instance variables in the receiver, including all
 inherited instance variables."

^ instVars
%

category: 'Accessing the Class Format'
method: Behavior
isBytes

"Returns true if instances of the receiver are byte objects.  Otherwise,
 returns false."

^ ((format \\ 4) == 1)
%

category: 'Accessing the Class Format'
method: Behavior
isIndexable

"Returns true if instances of the receiver have indexed variables.
 Otherwise, returns false."

^ ((format //4) \\ 2) == 1 "that is, is indexable"
%

category: 'Accessing the Class Format'
method: Behavior
isNsc

"Returns true if instances of the receiver are non-sequenceable
 collections (UnorderedCollections).  Otherwise, returns false."

^ (format \\ 4) == 2
%

category: 'Accessing the Class Format'
method: Behavior
isPointers

"Returns true if instances of the receiver are pointer objects.
 Otherwise, returns false."

^ (format \\ 4) == 0
%

category: 'Accessing the Class Format'
method: Behavior
_isSpecial

"Returns true if instances of the receiver are special objects.
 Otherwise, returns false."

^ (format \\ 4) == 3
%

category: 'Accessing the Class Format'
method: Behavior
instancesInvariant

"Returns true if instances of the receiver may not change value after they have
 been committed to GemStone.  Otherwise, returns false."

^ ((format // 8) \\ 2) == 1
%

category: 'Accessing the Class Format'
method: Behavior
subclassesDisallowed

"Returns true if subclasses of the receiver have been disallowed by means of
 Behavior | disallowSubclasses.  Otherwise, returns false."

^ ((format // 32) \\ 2) == 1
%

category: 'Accessing the Class Format'
method: Behavior
isProtected

"Returns true if instances of the receiver may not be accessed structurally
 through GemBuilder for C. "

^ ((format // 128) \\ 2) == 1
%

category: 'Accessing the Class Format'
method: Behavior
hasPublicInstVars

"Returns true if the receiver has publicly-visible instance variables."

^ instVars >= self firstPublicInstVar
%

! comments added re: bug 12857
category: 'Accessing the Class Format'
method: Behavior
firstPublicInstVar

"Returns the index of the first publicly available instance variable storage
 location, whether or not a public instance variable has actually been
 defined."

"Currently, an instance variable is considered to be public if it is to be
 included when passivating the object through PassiveObject.  Being public has
 no relationship to whether or not accessing or updating methods are defined
 for the instance variable."

^ 1
%

category: 'Accessing the Class Format'
method: Behavior
_firstGciPublicInstVar

"Returns the index of the first instance variable defined in this class for
 which structural updates are allowed through GemBuilder for C, if any."

^ self firstPublicInstVar
%

category: 'Accessing the Method Dictionary'
method: Behavior
_selectorAtMethod: aMethod

"Returns the selector of the given method."

| dictSize assoc |
dictSize := methodDict size .
1 to: dictSize do:[:j|
    assoc := methodDict _at: j .
    (assoc value == aMethod) ifTrue: [ ^assoc key ].
    ].
^'unknownMethod'
%

category: 'Enumerating'
method: Behavior
allSuperClassesDo: aBlock

"Evaluates aBlock with each of the receiver's superclasses as
 the argument, beginning with the immediate superclass."

| currClass |

currClass:= self.
[currClass superClass == nil]
whileFalse:
[
   aBlock value: (currClass superClass).
   currClass:= currClass superClass
]
%

category: 'Modifying Classes'
method: Behavior
disallowSubclasses

"Disallows creation of subclasses of a class.  If the receiver is not
 modifiable, this method generates an error.  If the receiver is modifiable and
 already has subclasses, this method generates an error."

self _validatePrivilege.
self validateIsModifiable .
self _subclasses size > 0 ifTrue:[ ^ self _error: #rtErrAlreadyHasSubclasses ].
format := format bitOr: 32
%

category: 'Modifying Classes'
method: Behavior
allowSubclasses

"Allows creation of subclasses of a class."

format := (format bitOr:32) bitXor: 32 .  "clear bit 32"
%


! fix bug 11794 and 11457
category: 'Modifying Classes'
method: Behavior
addInstVar: aSymbol withConstraint: aClass

"Adds a new instance variable named aSymbol to the receiver and constrains the
 value of that variable to be of the kind aClass.  The instance variable is 
 added in the same way and under the same conditions as described for the
 addInstVar: method.

 The argument aClass must be a kind of Class; otherwise, this method generates
 an error.

 Note that this method can be used if the receiver disallows subclasses and has
 no unnamed instance variables, even if it is not modifiable.  Note also that
 the instVar:constrainTo: method cannot be used under those conditions."

| ivInfo offset |

self _validatePrivilege.
aClass _validateIsClass .
self addInstVar: aSymbol .
"if addInstVar: succeeded then we should be able to add the constraint"
self isModifiable
  ifTrue:[ self instVar: aSymbol constrainTo: aClass]
  ifFalse:[
    "do a subset of instVar:constrainTo: assuming subclasses disallowed"
    ivInfo := self _ivOffsetAndConstraint: aSymbol .
    (ivInfo == nil) ifTrue:[ ^ self _error: #classErrNotAVar args:#[aSymbol] ] .
    offset := ivInfo at: 1 .
    aClass validateSubclassOf: (superClass _namedIvConstraintAtOffset: offset) .
    self _newConstraint: aClass atOffset: offset .
    ].
^ self
%

category: 'Modifying Classes'
method: Behavior
instVar: aString constrainTo: aClass

"Changes the receiver's constraint on the instance variable named
 aString to aClass.

 The argument aString must be the name of an instance variable defined in the
 receiver or inherited from a superclass.  aClass must be a kind of Class.
 The receiver, and any subclasses for which a constraint change will result,
 must be modifiable; otherwise, an error will be generated.

 If the superclass of the receiver has a constraint on the same instance
 variable, then aClass must be identical to, or a subclass of, that inherited
 constraint.

 For each of the receiver's subclasses, if the constraint on the specified
 instance variable is aClass or is a subclass of aClass, then that constraint
 will be unchanged.  Otherwise, the subclass's constraint will be changed to
 aClass."

| aSymbol ivInfo offset mySubclasses |
self _validatePrivilege.
aClass _validateIsClass .
aSymbol := aString asSymbol .
ivInfo := self _ivOffsetAndConstraint: aSymbol .
(ivInfo == nil) ifTrue:[ ^ self _error: #classErrNotAVar args:#[aSymbol] ] .
offset := ivInfo at: 1 .
aClass validateSubclassOf: (superClass _namedIvConstraintAtOffset: offset) .
self validateIsModifiable .
mySubclasses := self _subclasses .
mySubclasses do:[:x|
   x _validateNewInheritedConstraint:aClass atOffset:offset
   ] .
self _newConstraint: aClass atOffset: offset .
mySubclasses do:[:x| x _newInheritedConstraint: aClass atOffset: offset ] .
^ self
%

category: 'Modifying Classes'
method: Behavior
isModifiable

"Returns true if the receiver may be modified (that is, if the receiver, its
 Array of constraints, and its Array of instance variable names are all
 variant, and the receiver has a 'subclasses' class variable).  Returns false
 otherwise."

^ ((self isInvariant) | (constraints isInvariant) | (instVarNames isInvariant)
   ) not
  & (self _subclasses ~~ nil)
%

category: 'Modifying Classes'
method: Behavior
validateIsModifiable

"Returns the receiver if the receiver, its Array of constraints, and its
 Array of instance variables are modifiable.  Generates an error if the
 receiver cannot be modified (that is, if the receiver, its Array of
 constraints, or its Array of instance variable names is not variant)."

self isModifiable ifFalse:[ ^ self _error: #rtErrClassNotModifiable ]
%

category: 'Modifying Classes'
method: Behavior
validateSubclassesAreModifiable

"Generates an error if the receiver or any of its subclasses cannot be
 modified."

self validateIsModifiable .
self _subclasses do:[:x| x validateSubclassesAreModifiable ].
^ self
%

category: 'Modifying Classes'
method: Behavior
_removeClassVar: aSymbol

"Removes the class variable with name aSymbol from the receiver's
 class variables dictionary.  Generates an error if aSymbol is not
 the name of a class variable of the receiver."

  self _validatePrivilege.
  classVars removeKey: aSymbol
            ifAbsent: [classVars _errorKeyNotFound: aSymbol].
  ^ self
%

category: 'Modifying Classes'
method: Behavior
_removeClassVar: aSymbol ifAbsent: exceptionBlock

"Removes the class variable with name aSymbol from the receiver's
 class variables dictionary.  Executes exceptionBlock if aSymbol is not
 the name of a class variable of the receiver."

  self _validatePrivilege.
  classVars removeKey: aSymbol
            ifAbsent: exceptionBlock .
  ^ self
%

category: 'Modifying Classes'
method: Behavior
_subclasses

"Returns the class variable that is the list of subclasses, or
 nil if the receiver does not keep track of subclasses."

^ nil
%

category: 'Modifying Classes'
method: Behavior
immediateInvariant

"Recompiles all methods for the receiver.  If the receiver has a Subclasses
 class variable, also recompiles all methods for subclasses.  This
 recompilation is performed to check for references to deleted instance
 variables.

 If no errors found during compilation, then makes the receiver immediately
 invariant.

 If no errors found during compilation, and if subclasses are allowed, then
 makes the receiver's Array of constraints, and the receiver's Array of
 instance variable names immediately invariant.  If the receiver has a
 Subclasses class variable, it is removed.

 If errors occur during compilation, then the receiver is not made invariant."

"Overrides the inherited protocol from Object."

self _validatePrivilege.
self recompileAllSubclassMethodsInContext: System myUserProfile symbolList .
self subclassesDisallowed ifFalse:[
    "only make the instVarNames and Constraints collections invariant if we
     are not permitting possible dynamic addition of named instance variables.
    "
  (constraints isKindOf: Array) ifTrue:[ constraints immediateInvariant].
  instVarNames immediateInvariant.
  ] .
"clear the subclasses class instance variable to prevent concurrency problems"
self _subclasses ~~ nil ifTrue:[ 
  self _subclasses: nil .
  ] .
super immediateInvariant .  "make self invariant"
self _refreshClassCache .
%

category: 'Modifying Classes'
method: Behavior
_removeAllSubclassCode

"Dereference the code objects of all GsMethods of the receiver,
 to force recompilation of those methods."

| theSubclasses |
self _validatePrivilege.
theSubclasses := self _subclasses .
theSubclasses ~~ nil ifTrue:[
  theSubclasses do:[:x| x _removeAllSubclassCode ] .
  ].
methodDict keysAndValuesDo: [ :aKey :aMethod |
  methodDict at: aKey put: ((methodDict at: aKey) _copyToForceRecompilation).
  ].
self _refreshClassCache .
^ self
%

category: 'Modifying Classes'
method: Behavior
recompileAllSubclassMethodsInContext: aSymbolList

"Recompiles all methods for the receiver and its subclasses, using
 the specified symbol list.  If the receiver is not modifiable,
 then methods in subclasses will not be recompiled, since only
 modifiable classes should have the Subclasses class variable present."

| theSubclasses |
self _validatePrivilege.
self _removeAllSubclassCode .
self recompileAllMethodsInContext: aSymbolList .
theSubclasses := self _subclasses .
theSubclasses ~~ nil ifTrue:[
  theSubclasses do:[:x | x recompileAllSubclassMethodsInContext: aSymbolList ]
  ].
^ self
%

category: 'Modifying Classes'
method: Behavior
recompileAllMethodsInContext: aSymbolList

"Recompiles all methods for the receiver, using the specified symbol list.

 This method is designed to allow a user interface to issue GciContinue after
 fixing the source code for a method in error.  GciContinue will reattempt the
 compilation of the method which contained an error, then proceed to the next
 method."

| categoryList |
self _validatePrivilege.
categoryList := categories copy .
categoryList associationsDo: [:aCategoryAssoc| | selectorList theCategory | 
  theCategory := aCategoryAssoc key .
  selectorList := aCategoryAssoc value copy .
  selectorList do: [ :aSelector| | theSource  errors |
    [ "this Block supports GciContinue"
      "Make sure the method is there before trying to recompile it.
       An exception handler may have removed the method!"
      (self includesSelector: aSelector) ifTrue: [
        theSource:= self sourceCodeAt: aSelector .
        errors := self compileMethod: theSource dictionaries: aSymbolList
                        category: theCategory .
        (errors == nil) ifFalse:[
          System signal: (ErrorSymbols at: #compilerErrStDB)
            args:#[errors, theSource, self, theCategory, aSymbolList, aSelector]
            signalDictionary: GemStoneError .
        ].
      ]
      ifFalse: [
        errors := nil
      ].
      errors == nil
    ] untilTrue
  ] "end do selectors"
].  "end do categories"
^ self
%

category: 'Modifying Classes'
method: Behavior
removeInstVar: aString

"Removes the instance variable named aString from the receiver and from all of
 the receiver's subclasses.  The receiver and all of its subclasses must be
 modifiable.

 All instance methods for the receiver and its subclasses are recompiled using
 the symbol list of the current user.  If an error occurs during recompilation
 of methods, the instance variable will have been removed from the receiver and
 from all of its subclasses, but some methods in some subclasses will not have
 been recompiled.

 You may not use this method to remove an inherited instance variable."

| ivInfo offset aSymbol |
self _validatePrivilege.
"validate that the instance variable exists"
aSymbol := aString asSymbol .
ivInfo := self _ivOffsetAndConstraint: aSymbol .
(ivInfo == nil) ifTrue:[ ^ self _error: #classErrNotAVar args:#[aSymbol] ] .
((superClass _ivOffsetAndConstraint: aSymbol) == nil)
     ifFalse:[ ^ self _error: #classErrRemoveInherIv args:#[aSymbol] ].
offset := ivInfo at: 1 .
"validate that self and all subclasses are modifiable"
self validateSubclassesAreModifiable .
self _removeInstVarAtOffset: offset .  "remove from self and all subclasses"
self recompileAllSubclassMethodsInContext: System myUserProfile symbolList
%

category: 'Modifying Classes'
method: Behavior
varyingConstraint: aClass

"Changes the constraint on the unnamed variables of the receiver.

 The argument aClass must be a kind of Class.  The receiver, and any subclasses
 for which a constraint change will result, must be modifiable.  Otherwise, an
 error will be generated.

 If the superclass of the receiver has a constraint on its unnamed part, then
 aClass must be identical to, or a subclass of, that inherited constraint.

 For each of the receiver's subclasses, if the constraint on that subclass's
 unnamed part is either aClass or a subclass of aClass, that constraint will
 be unchanged.  Otherwise, the subclass's constraint will be changed to
 aClass."

self _validatePrivilege.
(self isBytes)
    ifTrue:[ ^ self _error: #rtErrVaryingConstrBytes ].
(self isNsc) ifFalse:[
  (self isIndexable) ifFalse:[ ^ self _error: #rtErrVaryingConstrNonidx] ] .
self validateIsModifiable .
aClass _validateIsClass .
aClass validateSubclassOf:( superClass varyingConstraint ) .
self _subclasses do:[:x| x _validateNewVaryingConstraint: aClass].
self _setVaryingConstraint: aClass .
self _subclasses do:[:x| x _updateVaryingConstraint: aClass].
^ self
%

category: 'Modifying Classes'
method: Behavior
addInstVar: aString

"Adds a new instance variable named aSymbol to the receiver.  The argument
 aString must be a valid GemStone Smalltalk identifier and must be distinct from
 the names of all other instance variables previously defined for the receiver,
 its superclasses, and its subclasses.

 The new instance variable becomes the last named instance variable in the
 receiver, and is inserted at the appropriate position in each of the
 receiver's subclasses, to preserve the rules for inheritance of instance
 variables.  If, for any of the receiver's subclasses, the new instance
 variable is not the last named instance variable, then all instance methods
 for that subclass are recompiled using the symbol list of the current user.
 If an error occurs during recompilation of methods, the new instance
 variable will have been added to the receiver and all of its subclasses, but
 some methods in some subclasses will not have been recompiled.

 To successfully invoke this method, the receiver must meet one of these two
 conditions:

 * The receiver and all of its subclasses must be modifiable.
 * The receiver must disallow subclasses and must have no unnamed instance
   variables."

| newOffset theSymbol |
self _validatePrivilege.
"3.2, no error check for NSCs"
(self isBytes) ifTrue:[ ^ self _error: #rtErrInstvarAddToBytes ] .
theSymbol:= aString asSymbol .
theSymbol validateIsIdentifier .  
self _validateNewNamedInstVar: theSymbol .  "ensure unique name and variant"
newOffset := instVars + 1 .  "the offset of the new instance variable"
self _insertNamedInstVar: theSymbol atOffset: newOffset .
self _recompileMethodsAfterNewIvOffset: newOffset .
^ self
%

category: 'Accessing Constraints'
method: Behavior
allConstraints

"If the receiver defines a non-sequenceable collection (UnorderedCollection)
 class, this returns a single Class, the element kind of the receiver.

 Otherwise, this returns an Array of Classes.  Each element in that Array is
 the class kind of a corresponding instance variable.  The ordering of the
 elements in the Array is the same as the ordering of instance variables in the
 receiver."

^ Array withAll: constraints
%

! fix bug 11627
category: 'Accessing Constraints'
method: Behavior
constraintOn: aString

"Returns the class kind constraint for the instance variable represented by
 aString.  If the instance variable named aString is not constrained, returns
 Object.  If no instance variable named aString exists for objects whose
 Behavior is defined by the receiver, returns nil."

| aSymbol |
aSymbol := Symbol _existingWithAll: aString .
aSymbol == nil ifTrue:[ ^ nil ].
^ self _constraintOn: aSymbol
%

category: 'Accessing Constraints'
method: Behavior
_constraintOn: aString

"Returns the class kind constraint for the instance variable represented by
 aString.  If aString does not represent an instance variable of objects whose
 behavior is defined by the receiver, or if the instance variable aString is
 not constrained, returns nil."

1 to: instVars do: [ :i |
  aString = (instVarNames at: i) ifTrue: [^ constraints at: i].
  ].
^ nil
%

category: 'Accessing Constraints'
method: Behavior
_ivOffsetAndConstraint: aSymbol

"Searches the instVarNames instance variable of the receiver for an instance
 variable named aSymbol, and returns an Array containing the offset and the
 constraint for that instance variable.  Returns nil if no instance variable
 exists with the name aSymbol."

1 to: instVars do:[ :i | 
  aSymbol = (instVarNames at: i) ifTrue:[^ #[ i, constraints at: i] ].
  ].
^ nil
%

category: 'Accessing Constraints'
method: Behavior
_ivNameAndConstraintAt: anInteger

"Returns an Array containing the name and constraint for the
 instance variable of the receiver at the specified offset.
 Returns nil if there is no named instance variable at that offset."

( anInteger < 1) | (anInteger > instVarNames size) ifTrue:[ ^ nil ].
^ #[ instVarNames at:anInteger, constraints at: anInteger ]
%

category: 'Accessing Constraints'
method: Behavior
_stringToPath: aString

"Returns an Array of SmallIntegers representing offsets to the named instance
 variables named in the argument.  Called by GciStrToPath.  See specification
 of GciStrToPath for further details.  Receiver is the class at the root of the
 path."

| pathTerms stringPosition argSize nextDotPos nextName result
  termResult pathSize currClass |

aString _validateByteClass: CharacterCollection .

" following code should ideally be String|_asArrayOfPathTerms "
argSize := aString size .
pathTerms := Array new .
stringPosition := 1 .
[ (stringPosition <= argSize) ] whileTrue: [
  nextDotPos := aString findString: '.' startingAt: stringPosition .
  (nextDotPos == 0) ifTrue:[ nextDotPos := argSize + 1 ] .
  nextName := aString class new.
  aString copyFrom: stringPosition to: (nextDotPos - 1) into: nextName
          startingAt: 1 .
  nextName := Symbol _existingWithAll: nextName .
  nextName == nil ifTrue:[ nextName := #'' "no instVar has this name" ].
  pathTerms add: nextName.
  stringPosition := nextDotPos + 1 .
  ].
pathSize := pathTerms size .  " end of _asArrayOfPathTerms "

result := Array new.
currClass := self .
1 to: pathSize do:[:j|
  currClass == Object ifTrue:[
    ^ self _error: #rtErrStrToPathConstraint args:#[ j ]
    ].
  termResult := currClass _ivOffsetAndConstraint: (pathTerms at:j) .
  termResult == nil ifTrue:[
    ^ self _error: #rtErrStrToPathIvname
           args: #[ j, (pathTerms at:j), currClass ].
    ] .
  result add:(termResult at: 1).
  currClass := termResult at: 2.
  ] .
^ result
%

category: 'Accessing Constraints'
method: Behavior
_pathToString: anArray

"Returns a String representing symbolic form of the path given in the argument.
 Called by GciPathToStr.  See specification of GciPathToStr further details.
 Receiver is the class at the root of the path.  The argument must be an Array
 of positive SmallIntegers."

| argSize result termResult currClass |

anArray _validateClass: Array .

argSize := anArray size .
result := String new .

currClass := self .
1 to: argSize do:[:j|
  currClass == Object ifTrue:[
    ^ self _error: #rtErrStrToPathConstraint args:#[ j ]
    ].
  termResult := currClass _ivNameAndConstraintAt: (anArray at:j) .
  termResult == nil ifTrue:[
    ^ self _error: #rtErrPathToStrIvname args:#[ j, anArray at: j, currClass,
                            currClass allInstVarNames size ].
    ].
  result addAll:(termResult at: 1); addAll: '.' .
  currClass := termResult at: 2.
  ] .
result size: (result size - 1).  "chop off trailing dot character"
^ result
%

category: 'Accessing Constraints'
method: Behavior
_constraints

"Returns the constraints themselves, not a copy."

^ constraints
%

category: 'Accessing Constraints'
method: Behavior
_namedIvConstraintAt: anInteger

"Returns the constraint at the specified offset, or Object."

(anInteger > instVars ) ifTrue:[^ Object].
^ constraints at: anInteger
%

category: 'Accessing Constraints'
method: Behavior
varyingConstraint

"Returns the constraint on the unnamed part of the receiver (a kind of Class).
 If the receiver has no constraint on its unnamed part, or if it has no unnamed
 part, this method returns Object."

(constraints size > instVars)
     ifTrue:[ ^ constraints at: (constraints size) ]
     ifFalse:[ ^ Object "none defined yet" ]
%

category: 'Accessing Constraints'
method: Behavior
elementConstraint

"Returns the kind of objects that instances of the receiver can hold."

^ self varyingConstraint
%

category: 'Instance Creation'
method: Behavior
_basicNew

"This is a primitive.  Returns an instance of the receiver, with no indexed
 variables.  Do not override this method; contrast with Behavior | new."

<primitive: 50>

(self _isInstanceDisallowed)
ifTrue:[ self _error: #objErrCantCreateInstance args:  #()  .
         self _uncontinuableError
       ].
self _primitiveFailed: #_basicNew .
self _uncontinuableError
%

category: 'Instance Creation'
method: Behavior
new

"Returns an instance of the receiver with no indexed variables."

<primitive: 51>

self _primitiveFailed: #new .
self _uncontinuableError
%

category: 'Instance Creation'
method: Behavior
new: anInteger

"Returns an instance of the receiver with the specified number of indexed
 variables.  Generates an error if the receiver is not indexable or if
 anInteger is not a positive SmallInteger.

 For new byte objects, all indexed variables are set to zero;
 for new pointer objects, all indexed variables are set to nil."

<primitive: 53>

(self isIndexable)
ifFalse:[ self _errorNotIndexable .  ^ self new ].

(anInteger _isInteger)
  ifFalse:[ anInteger _validateClass: Integer . ]
  ifTrue:[
    (anInteger < 0) ifTrue:[ anInteger _error: #rtErrArgNotPositive .  
			    ^ self new].
    anInteger _error: #rtErrArgOutOfRange .  
    ^ self new 
    ].

self _primitiveFailed: #new: .
self _uncontinuableError
%

category: 'Instance Creation'
method: Behavior
migrateNew

"Create a new instance to use in migration.  By default, use #new.
Override in subclasses that can't use #new with #_basicNew. "

^ self new
%

category: 'Instance Creation'
method: Behavior
_basicNew: anInteger

"This is a primitive.  Returns with an instance of the receiver, with the given
 number of fields.  Generates an error if the Behavior is not indexable or if
 anInteger is bad.  Do not override this method; contrast with Behavior | new:."

<primitive: 52>

(self isIndexable) ifFalse:[self _errorNotIndexable .  ^ self _basicNew ].
anInteger _validateClass: SmallInteger.
(self _isInstanceDisallowed)
  ifTrue: [self _error: #objErrCantCreateInstance args:  #()  .
           self _primitiveFailed: #_basicNew: .
           self _uncontinuableError
          ].
(anInteger < 0)
  ifTrue:[anInteger _error: #rtErrArgNotPositive .  ^ self _basicNew ].

(anInteger + self instSize) class == SmallInteger
  ifFalse: [anInteger _error: #rtErrArgOutOfRange .  ^ self _basicNew ].

self _primitiveFailed: #_basicNew: .
self _uncontinuableError
%

! category: 'Formatting'
! method: Behavior
! describe
! 
! "Returns an instance of a subclass of CharacterCollection describing the
!  receiver."
! 
! ^String withAll: self name
! %

category: 'Formatting'
method: Behavior
asString

"Returns a String that indicates the class of the receiver."

^String withAll: self name
%

category: 'Clustering'
method: Behavior
clusterBehavior

"This method clusters, in depth-first order, the parts of the receiver required
 for executing GemStone Smalltalk code (the receiver and its method dictionary).
 Returns true if the receiver has already been clustered during the current
 transaction; returns false otherwise.

 It is recommended that when several classes are being clustered in a
 transaction, send clusterBehavior to all classes to be clustered, then send
 clusterDescription."

self cluster
  ifTrue:[ ^ true ]
  ifFalse:[
    self _rebuildMethodDict .
    constraints cluster .
    methodDict clusterDepthFirst.
    classVars cluster .
    classVars doAssociations:[:assoc| assoc cluster ].
    ^ false
    ].
%

category: 'Clustering'
method: Behavior
_rebuildMethodDict 

"Rebuild the receiver's method dictionary to optimize the hash table
 in the dictionary."

"Do not rebuild the method dictionary while it can be used for lookups.
 Must copy the dictionary, rebuild the copy, and then install the copy."

| newDict |

self _validatePrivilege.
newDict := methodDict copy .
newDict rebuildIfNeeded ifTrue:[
  methodDict := newDict .
  self _refreshClassCache .
  ].
%

! fix bug 14726
category: 'Clustering'
method: Behavior
clusterDescription

"This method clusters, in depth-first order, those instance variables in the
 receiver that describe the structure of the receiver's instances.  The
 following instance variables are clustered: instVarNames, classVars, and
 categories.  (The receiver itself is not clustered.)  Returns true if the
 receiver has already been clustered during the current transaction; returns
 false otherwise.

 It is recommended that when several classes are being clustered in a
 transaction, send clusterBehavior to all classes to be clustered, then send
 clusterDescription."

instVarNames cluster
  ifTrue:[ ^ true ]
  ifFalse:[
    poolDictionaries cluster .
    categories rebuildIfNeeded.
    categories clusterDepthFirst. 
    ^ false
    ].
%

category: 'Clustering'
method: Behavior
clusterBehaviorExceptMethods: aCollectionOfMethodNames

"This method allows you to cluster the receiver more efficiently by omitting
 infrequently-used methods from the clustering.  The methods that you designate
 as aCollectionOfMethodNames will not be clustered with the receiver.  Thus,
 the methods that are frequently used will be packed more densely.  Returns
 true if the receiver has already been clustered during the current
 transaction; returns false otherwise.

 This method works by first clustering all methods named into the max cluster
 bucket, preventing them from showing up in the default cluster bucket.  It
 then uses the standard method to cluster behavior."

| savedBucket otherBucket systm |
systm := System .
savedBucket := systm clusterBucket.
otherBucket := 6 .
systm clusterBucket: otherBucket.
methodDict keysAndValuesDo: [ :aSelector :aMethod |
    (aCollectionOfMethodNames includesValue: aSelector )
      ifTrue: [ aMethod clusterDepthFirst ].
  ].
systm clusterBucket: savedBucket.
^ self clusterBehavior
%

category: 'Copying'
method: Behavior
copy

"Returns the receiver. Copies of classes and metaclasses are not made."

^ self.
%

category: 'Private'
method: Behavior
_deepCopyWith: copiedObjDict

"Private. Used internally to implement deepCopy."

^ self.
%

category: 'Accessing Categories'
method: Behavior
categoryNames

"Returns an Array of Symbols.  The elements of the Array are the
 receiver's category names (excluding names inherited from superclasses)."

 | result j |
 result := Array new: categories size .
 j := 1 .
 categories keysAndValuesDo:[ :aKey :aValue |
   result at: j put: aKey .
   j := j + 1 
   ]. 
 ^ result
%

category: 'Accessing Categories'
method: Behavior
sortedCategoryNames

"Returns an Array of Symbols.  The elements of the collection are the
 receiver's category names (excluding names inherited from superclasses)."

 | coll |
 coll := SortedCollection new .
 categories keysAndValuesDo:[:aKey :aValue | coll add: aKey ].
 ^ Array withAll: coll .
%

category: 'Indexing Support'
method: Behavior
_ivOffsetOf: aSymbol

"Searches the instVarNames instance variable of the receiver for an instance
 variable named aSymbol, and returns the offset for that instance variable.
 Returns nil if no instance variable exists with the name aSymbol."

1 to: instVars do: [ :i |
   aSymbol == (instVarNames at: i) ifTrue: [ ^ i ]
   ].
^ nil
%

category: 'Browsing'
method: Behavior
_categoryOfSelector: selector

"Returns the category of the given selector, or 'unknown' if it isn't found."

 | result |
 (result := self categoryOfSelector: selector) == nil ifTrue:[ 
    ^ 'unknown'
    ].
 ^ result
%

! fix bug 8527 
category: 'Browsing'
method: Behavior
_copyMethodsAndVariablesFrom: sourceClass except: except dictionaries: dicts

"Copies all instance and class methods, pool dictionaries, and references
 to class variables from the given class to ourselves.  Returns an Array of
 methods in the source class which failed to compile.  Some of them
 might be class methods.  The Array will be empty if none failed.

 The except: argument is a list of categories and/or methods that should
 not be copied.  Each exception is two elements in the Array: a Character
 followed by a String or Symbol.
    $C a category of class methods follows
    $c a category of instance methods follows
    $S the selector of a class method follows
    $s the selector of an instance method follows
    $V a list of class variable names follows
    $P a list of pool dictionaries follows"

| failed result srccls targcls cats sel doit pds cvs i |

self _validatePrivilege.
failed := Array new.
pds :=  #() .
cvs :=  #() .

except ~~ nil ifTrue: [
  i := except indexOf: $P.
  i > 0 ifTrue: [ pds := except at: i+1 ].
  i := except indexOf: $V.
  i > 0 ifTrue: [ cvs := except at: i+1 ].
  ].

"Copy pool dictionaries"
sourceClass.poolDictionaries do: [ :dict |
  (poolDictionaries includesIdentical: dict) ifFalse: [
    (pds includesIdentical: dict) ifFalse: [
      poolDictionaries add: dict
    ].
  ].
].

"Copy class variables"
sourceClass _classVars associationsDo: [ :assn | | other |
  other := classVars associationAt: assn key otherwise: nil.
  (other == nil _or: [other value == nil _and: [assn value ~~ nil]]) ifTrue: [
    (cvs includesValue: assn key) ifFalse: [
      classVars add: assn
    ].
  ].
].

"Copy class and instance methods"
1 to: 2 do: [ :i |
  i == 1 ifTrue: [
    srccls := sourceClass.  targcls := self
  ]
  ifFalse: [
    srccls := sourceClass class.  targcls := self class
  ].

  cats := srccls _categories.
  cats keysAndValuesDo: [ :cat :sels |

    1 to: sels size do: [ :s |
      sel := sels at: s.
      result := nil.

      doit := true.
      1 to: except size by: 2 do: [ :i |
	(((((except at: i) = $C _and: [targcls isMeta _and: [cat == (except at: i + 1)]]) _or:
          [(except at: i) = $S _and: [targcls isMeta _and: [sel == (except at: i + 1)]]]) _or:
          [(except at: i) = $c _and: [targcls isMeta not _and: [cat == (except at: i + 1)]]]) _or:
          [(except at: i) = $s _and: [targcls isMeta not _and: [sel == (except at: i + 1)]]]) ifTrue: [
        doit := false ].
      ].

      doit ifTrue: [
        result := targcls 
           _compileMethodTrappingErrors: (srccls sourceCodeAt: sel)
           dictionaries: dicts category: cat.
      ].
      result == nil ifFalse: [
        failed add: (srccls _methodDict at: sel)
      ].
    ].
  ].
].

^failed.
%

! fix bug 8086
category: 'Updating the Method Dictionary'
method: Behavior
_compileMethodTrappingErrors: sourceString
dictionaries: aSymbolList
category: aCategoryString

"If there are no errors, add the resulting compiled method to the receiver's
 method dictionary and returns nil.
 
 If errors occur, returns an Array of pairs.  The first element of each pair is
 the GemStone error number, and the second element is the offset into the
 sourceString where the error occurred.

 This method differs from compileMethod:dictionaries:category: in that it
 traps all errors (not just compiler errors).  Non-compiler errors are
 reported with a source offset of 0."

  self _validatePrivilege.
  Exception category: nil number: nil do: [ :ex :cat :num :args |
     "We have an error that is not a compiler error, since the
      compilation method fields compiler errors itself."

     ^Array with: (Array with: num with: 0) 
     ].
  ^ self
     compileMethod: sourceString
     dictionaries: aSymbolList
     category: aCategoryString
%

category: 'Accessing Variables'
method: Behavior
_instVarNames

"Returns the receiver's instance variables list.  Contrast with the public
 method #allInstVarNames."

^instVarNames
%

category: 'Accessing the Method Dictionary'
method: Behavior
_methodWithSource: str

"Returns the method from the method dictionary whose source is given, or
 nil if not found."

methodDict keysAndValuesDo: [ :aSelector :aMethod | 
  aMethod sourceString = str ifTrue: [ ^aMethod ].
  ].

^nil.
%

category: 'Browsing'
method: Behavior
_recategorize: cats

"Installs the given SymbolDictionary as the receiver's method categorization."

self _validatePrivilege.
categories removeAll .
categories addAll: cats
%

category: 'Instance Creation'
method: Behavior
basicNew

"Creates a new, uninitialized instance of the receiver."

^self _basicNew
%

category: 'Instance Creation'
method: Behavior
basicNew: anInteger

"Creates a new, uninitialized instance of the receiver with the given
 number of indexed instance variables."

^self _basicNew: anInteger
%

category: 'Category'
method: Behavior
category

"Returns the classCategory instance variable of the receiver.  If the receiver's
 category is nil, returns its superclass's category."

| categ |
categ := self _classCategory .
categ == nil ifTrue: [
  superClass == Object ifTrue: [
    ^'User Classes'
  ].
  superClass == nil ifTrue: [
    ^'Kernel'
  ].
  ^ superClass category
].
^ categ
%

category: 'Private'
method: Behavior
_classCategory

"Private."

"The classCategory instance variable is defined in Class, so return nil here."

^ nil
%

category: 'Browsing'
method: Behavior
copyMethodsFrom: sourceClass dictionaries: dicts

"Copies all instance and class methods from the sourceClass.  Returns an Array
 of methods in the source class which failed to compile in this class.  Some of
 them might be class methods.  The Array is empty if no methods failed to
 compile."

| failed srccls targcls cats |

self _validatePrivilege.
failed := Array new.

"Copy class and instance methods"
1 to: 2 do: [ :i |
  i == 1 ifTrue: [
    srccls := sourceClass.  targcls := self
  ]
  ifFalse: [
    srccls := sourceClass class.  targcls := self class
  ].

  cats := srccls _categories.
  cats keysAndValuesDo: [ :cat :sels |
    sels do: [ :sel | | result |
      result := targcls compileMethod: (srccls sourceCodeAt: sel)
                    dictionaries: dicts category: cat.

      result == nil ifFalse: [
	failed add: (srccls _methodDict at: sel)
      ].
    ].
  ].
].

^failed.
%

category: 'Fileout'
method: Behavior
fileOutCategories

"Returns a string with all the receiver's methods in Topaz Filein format."

| str |

str := String new.
self fileOutCategoriesOn: (WriteStream on: str).
^str
%

category: 'Fileout'
method: Behavior
nameForFileout

"Returns the name to be used for this class for fileout."

| pair nm |
pair := System myUserProfile dictionaryAndSymbolOf: self.
nm := pair == nil ifTrue: [ self thisClass name ] ifFalse: [ pair at: 2 ].
^nm
%

category: 'Fileout'
method: Behavior
fileOutCategoriesOn: stream

"Writes the receiver's categories and methods onto the given stream
 in Topaz filein format."

| lf cls cats nm |

cls := self isMeta ifTrue: [self thisClass] ifFalse: [self].
lf := Character lf.
stream nextPut: lf.
nm := self nameForFileout.

self fileOutMethodRemovalOn: stream name: nm.

self fileOutPreMethodsOn: stream.

stream nextPutAll: '! ------------------- Class methods for '; nextPutAll: nm; nextPut: lf.
cats := SortedCollection new.
cats addAll: (cls class categoryNames).
cats do: [:category |
  cls class fileOutCategory: category on: stream
].

stream nextPutAll: '! ------------------- Instance methods for '; nextPutAll: nm; nextPut: lf.
cats := SortedCollection new.
cats addAll: (cls categoryNames).
cats do: [:category |
  cls fileOutCategory: category on: stream
].

self fileOutPostMethodsOn: stream.

^stream
%

category: 'Fileout'
method: Behavior
fileOutCategory: catName

"Returns a string containing the methods of the given category in
 Topaz Filein format."

| str |

str := String new.
self fileOutCategory: catName on: (WriteStream on: str).
^str
%

category: 'Fileout'
method: Behavior
fileOutCategory: catName on: stream

"Files out the given category on the given stream."

| hdr sels |

hdr := 'category: ''' , catName , $' , Character lf.
sels := self sortedSelectorsIn: catName.
sels do: [:selector |
  stream nextPutAll: hdr.
  self fileOutMethod: selector on: stream
]
%

category: 'Fileout'
method: Behavior
fileOutClass

"Returns a string with the receiver's class definition and all the
 receiver's methods in Topaz Filein format."

| str |

str := String new.
self fileOutClassOn: (WriteStream on: str).
^str
%

category: 'Fileout'
method: Behavior
fileOutClassByCategoryOn: stream

"Writes the receiver's definition and methods onto the given stream in
 filein format."

self fileOutPreClassOn: stream.
stream nextPutAll: 'doit'; nextPut: Character lf;
      nextPutAll: self definition; nextPut: Character lf;
      nextPut: $%; nextPut: Character lf.
self fileOutCategoriesOn: stream.
%

category: 'Fileout'
method: Behavior
fileOutClassOn: stream

"Writes the receiver's definition and methods onto the given stream in
 filein format."

self fileOutPreClassOn: stream.
stream nextPutAll: 'doit'; nextPut: Character lf;
      nextPutAll: self definition; nextPut: Character lf;
      nextPut: $%; nextPut: Character lf.
self fileOutMethodsOn: stream.
%

category: 'Accessing the Method Dictionary'
method: Behavior
categoryOfSelector: aSelector

"Returns a Symbol which is the name of the category for the specified
 selector, or nil if the selector was not found in any category."

| aSymbol |
aSymbol := Symbol _existingWithAll: aSelector .
aSymbol == nil ifTrue:[ ^ nil ].
categories keysAndValuesDo: [:aKey :aValue | 
  (aValue includesIdentical: aSymbol ) ifTrue:[ ^ aKey ].
  ].
^ nil
%

category: 'Fileout'
method: Behavior
fileOutMethod: selector

"Returns a string with the given method's category and source in Topaz
 Filein format."

| str cat |

(cat := self categoryOfSelector: selector) == nil ifTrue:[ 
  ^ self _error: #assocErrNoElementsDetected 
  ].

str := String new.
str addAll: 'category: '''; addAll: cat; add: $'; add: Character lf.
self fileOutMethod: selector on: ((WriteStream on: str) position: str size + 1).
^str
%

category: 'Fileout'
method: Behavior
fileOutMethod: selector on: stream

"Writes the given method's source to the given stream in Topaz Filein format."

| lf src |

lf := Character lf.
stream nextPutAll: (self isMeta ifTrue: [ 'classmethod: ' ]
              ifFalse: [ 'method: ' ]).
stream nextPutAll: self nameForFileout; nextPut: lf.
src := self sourceCodeAt: selector.
stream nextPutAll: src.
src last == lf ifFalse: [
  stream nextPut: lf
].
stream nextPutAll: '%
'
%

category: 'Fileout'
method: Behavior
fileOutMethodRemovalOn: stream name: nm

"Writes code to remove all the receiver's methods onto the given stream
 in filein format."

stream nextPutAll: '! Remove existing behavior from ';
       nextPutAll: nm;
       nextPutAll: '
doit
';
       nextPutAll: nm;
       nextPutAll: ' removeAllMethods.
';
       nextPutAll: nm;
       nextPutAll: ' class removeAllMethods.
';
       nextPutAll: '%
'.
%

category: 'Fileout'
method: Behavior
fileOutMethods

"Returns a string with all the receiver's methods in Topaz Filein format."

| str lf cls |

cls := self isMeta ifTrue: [self thisClass] ifFalse: [self].
lf := Character lf.
str := String new.
self fileOutMethodsOn: (WriteStream on: str).
^str
%

category: 'Fileout'
method: Behavior
fileOutMethodsOn: stream

"File out this class's methods, but sort the selectors alphabetically."

| lf cls sels sel clamps cat nm |

stream == nil ifTrue: [^self].
cls := self thisClass.
nm := self nameForFileout.
lf := Character lf.
stream nextPut: lf.

self fileOutMethodRemovalOn: stream name: nm.

self fileOutPreMethodsOn: stream.

clamps := false.
stream nextPutAll: '! ------------------- Class methods for '; nextPutAll: nm; nextPut: lf.
sels := SortedCollection withAll: (cls class selectors).
1 to: sels size do: [:i |
  sel := sels at: i.
  stream nextPutAll: 'category: '''; nextPutAll: (cls class _categoryOfSelector: sel);
      nextPut: $'; nextPut: lf.
  cls class fileOutMethod: sel on: stream.
  (clamps not _and: [sel == #clampedInstVars]) ifTrue: [
    clamps := true
  ].
].

stream nextPutAll: '! ------------------- Instance methods for '; nextPutAll: nm; nextPut: lf.
sels := SortedCollection withAll: (cls selectors).
1 to: sels size do: [:i |
  sel := sels at: i.
  stream nextPutAll: 'category: '''; nextPutAll: (cls _categoryOfSelector: sel);
      nextPut: $'; nextPut: lf.
  cls fileOutMethod: sel on: stream
].

"Special check for #clampedInstVars."
clamps ifTrue:
  [
  stream nextPutAll: 'doit
';
          nextPutAll: nm;
          nextPutAll: ' compileClampedInstVars
';
    nextPut: $%;
    nextPut: lf.
  ].

"File out the category name"
cat := self _classCategory .
cat ~~ nil ifTrue:
  [
  stream nextPutAll: 'doit
';
          nextPutAll: nm;
          nextPutAll: ' category: ';
          nextPutAll: cat quoted;
          nextPut: lf; nextPut: $%; nextPut: lf.
  ].

self fileOutPostMethodsOn: stream.

^stream
%

category: 'Fileout'
method: Behavior
fileOutPostMethodsOn: stream

"This method gives classes an opportunity to file out information not
 normally emitted by the predefined fileout methods.  Classes may override
 this method (as a class method, of course) to add extra code to the
 output stream.  Emitted code should be in Topaz filein format.  It will
 be placed after method creation."

%

category: 'Fileout'
method: Behavior
fileOutPreClassOn: stream

"This method gives classes an opportunity to file out information not
 normally emitted by the predefined fileout methods.  Classes may override
 this method (as a class method, of course) to add extra code to the
 output stream.  Emitted code should be in Topaz filein format.  It will
 be placed before any other fileout information for the class."

%

category: 'Fileout'
method: Behavior
fileOutPreMethodsOn: stream

"This method gives classes an opportunity to file out information not
 normally emitted by the predefined fileout methods.  Classes may override
 this method (as a class method, of course) to add extra code to the
 output stream.  Emitted code should be in Topaz filein format.  It will
 be placed after existing method removal and before method creation."

%

! delete duplicate

category: 'Accessing the Class Format'
method: Behavior
isBytesOrSpecial

"Returns whether instances of the receiver are byte objects."

^((format bitAnd: 1) == 1)
%

! delete duplicate 

category: 'Queries'
method: Behavior
isSpecial

"Returns whether instances of this class have their state encoded in their
 identities."

^self _isSpecial
%

category: 'Accessing the Class Format'
method: Behavior
isVariable

"Returns true if instances of the receiver have an unnamed part."

self isIndexable ifTrue: [^true].
self isNsc ifTrue: [^true].
^false
%

category: 'Accessing Variables'
method: Behavior
offsetOfInstVar: aSymbol

"Returns the integer offset at which the instance variable named aSymbol is
 stored in instances of the receiver.  Returns zero if the instance variable
 is not found."

^instVarNames indexOf: aSymbol.
%

category: 'Analysis'
method: Behavior
referencedStrings

"Returns a Set containing all Strings and InvariantStrings referenced by
 the methods in this Class and its Metaclass."

| set |

set := IdentitySet new.
#[self, self class] do: [ :cls | | dict |
  dict := cls _methodDict.
  dict doValues: [ :aGsMethod |
    aGsMethod literalsOffset to: aGsMethod size do: [ :j | | obj |
      obj := aGsMethod at: j.
      ((obj isKindOf: CharacterCollection) _and: [obj isSymbol not]) ifTrue: [
	set add: obj
      ].
    ].
  ].
].
^set.
%

category: 'Browsing'
method: Behavior
removeSelector: aString ifAbsent: aBlock

"Removes the method whose selector is aString from the receiver's
 method dictionary.  If the selector is not in the method
 dictionary, returns the result of evaluating the
 zero-argument block aBlock.  Otherwise, returns the receiver."

| aKey |

self _validatePrivilege.
aKey := aString asSymbol .
(methodDict includesKey: aKey) ifFalse:[ ^ aBlock value ] .
self removeSelector: aKey .
%

category: 'Updating Categories'
method: Behavior
renameOrMergeCategory: oldName to: newName

"Changes the name of the specified category to newName (a String), and
 returns the receiver.  If oldName is not in the receiver's method
 dictionary, generates an error.  If newName is already in the receiver's
 category list, moves all the methods from the old category to the new
 category, and removes the old category."

| sels oldsym newsym |

self _validatePrivilege.
oldsym := oldName asSymbol.
sels := categories at: oldsym otherwise: nil.
sels == nil ifTrue: [
  ^ self _error: #classErrMethCatNotFound args: #[oldName] ].  "key not found"

newsym := newName asSymbol.
(categories includesKey: newsym) ifTrue: [
  sels size downTo: 1 do: [ :i |
    self moveMethod: (sels at: i) toCategory: newsym
  ].
  categories removeKey: oldsym ifAbsent: [].
]
ifFalse: [
  (categories includesKey: oldsym) ifTrue: [
    categories add:
	(SymbolAssociation new key: newsym value: (categories at: oldsym)).
    categories removeKey: oldsym.
  ].
].
%

category: 'Accessing Categories'
method: Behavior
_includesCategory: aString

"Returns true if aString is equivalent to the name of a category in the
 receiver, false otherwise."

^ categories includesKey: aString asSymbol
%

category: 'Accessing Categories'
method: Behavior
selectorsIn: categoryName

"Returns an Array of all selectors in the specified category.  If categoryName
 is not in the receiver's method dictionary, generates an error."

^ Array withAll: (categories at: (categoryName asSymbol)) 
%

category: 'Accessing Categories'
method: Behavior
sortedSelectorsIn: categoryName

"Returns an Array of all selectors in the specified category, sorted
 in ascending order."

 | coll |
 coll := SortedCollection new .
 (categories at: (categoryName asSymbol)) do:[:aKey | coll add: aKey ].
 ^ Array withAll: coll
%

category: 'Accessing the Class Hierarchy'
method: Behavior
superclass

"Returns the receiver's superclass."

^ superClass
%

category: 'Indexing Support'
method: Behavior
btreeLeafNodeClass

"Returns the class of BtreeLeafNode to create for an equality index whose last
 object along the path is an instance of the receiver."

| result |
(RangeEqualityIndex isBasicClass: self)
    ifTrue: [ result := self indexManager btreeBasicLeafNodeClass]
    ifFalse: [ result := self indexManager btreeLeafNodeClass ].
^ result
%

category: 'Indexing Support'
method: Behavior
rcBtreeLeafNodeClass

"Returns the class of BtreeLeafNode to create for an equality index whose last
 object along the path is an instance of the receiver."

| result |
(RangeEqualityIndex isBasicClass: self)
    ifTrue: [ result := self indexManager rcBtreeBasicLeafNodeClass]
    ifFalse: [ result := self indexManager rcBtreeLeafNodeClass ].
^ result
%

category: 'Indexing Support'
method: Behavior
sortNodeClass

"Returns the class of SortNode to create for sorting on instances of the
 receiver."

| result |
(RangeEqualityIndex isBasicClass: self)
    ifTrue: [ result := self indexManager sortNodeClass ]
    ifFalse: [ result := SortNode ].
^ result
%

category: 'Stripping Sources'
method: Behavior
_hideSourceCode

"For each method defined for this class, hide the source code.  All that
 remains of the source is the method signature and the initial comment if one
 exists."

self _validatePrivilege.
methodDict doValues: [ :compMeth |
    compMeth _removeAllSourceButFirstComment
]
%

category: 'Reloading Decompiled Methods'
method: Behavior
_addMethod: aGsMethod inCategory: aCategory

"Private.  Used to regenerate a compiled method from decompiled form."

| selector oldMethod categColl |

self _validatePrivilege.
selector := aGsMethod _selector .

oldMethod := methodDict at: selector ifAbsent:[nil] .
oldMethod ~~ nil ifTrue:[
  "remove selector from whatever existing category it's in"
  categories doValues:[:aSymbolSet| 
     (aSymbolSet includesIdentical: selector) ifTrue:[ 
        aSymbolSet remove: selector 
        ].
     ] .
  ].

"add to method dictionary and specified category"
methodDict at: selector put: aGsMethod .
categColl := categories at: aCategory asSymbol otherwise: nil .
categColl == nil ifTrue:[
  categColl := SymbolSet new .
  categories at: aCategory put: categColl 
  ].
categColl add: selector .

self _refreshCodeCache: oldMethod newMethod: aGsMethod
%
category: 'Reloading Decompiled Methods'
method: Behavior
_refreshCodeCache: oldGsMethod newMethod: newGsMethod

<primitive: 165>
oldGsMethod _validateClass: GsMethod .
newGsMethod _validateClass: GsMethod .
oldGsMethod ~~ nil ifTrue:[
  oldGsMethod selector == newGsMethod selector ifFalse:[
    self _halt: '_refreshCodeCache:newMethod:  inconsistent selectors' .
    ].
  oldGsMethod inClass == self ifFalse:[
    self _halt: '_refreshCodeCache:newMethod:  old method class inconsistent' .
    ].
  ].
newGsMethod inClass == self ifFalse:[
  self _halt: '_refreshCodeCache:newMethod:  new method class inconsistent' .
  ].
self _primitiveFailed: #_refreshCodeCache:newMethod:
%

category: 'Private'
method: Behavior
_noStrippedMethodSelectors

"Returns an Array of two empty Arrays, signifying that no methods are to have
 their source stripped."

<primitive: 901>
| result |
result := #( #() #() ).
System _disableProtectedMode.
^ result
%

category: 'Private'
method: Behavior
_allStrippedMethodSelectors

"Returns an Array of two Arrays, signifying that all methods of the receiver
 are to have their source stripped."

<primitive: 901>
| result |
result := #[ self selectors, self class selectors ].
System _disableProtectedMode.
^ result
%

category: 'Private'
method: Behavior
_stripAllMethodSources

"Returns true if all method sources should be stripped for the receiver, and
 false otherwise."

"Returns true for the list of classes given in the code, false for others."

| classNameList |
" classNameList is an Array of Symbols because some of these classes 
are not known at filein "
classNameList := #( ).

1 to: classNameList size do: [ :i |
  ((Globals at: (classNameList at: i)) == self)
    ifTrue: [ ^ true ]
].
^ false
%

! fix bug 11618
category: 'Reloading Decompiled Methods'
method: Behavior
_resolveClassVar: aSymbol 

"Searches the receiver's class variables dictionary, to attempt to resolve
 aSymbol.  Returns the SymbolAssociation for the variable with name aSymbol, or
 nil if aSymbol could not be found."

| assoc |

classVars size > 0 ifTrue:[
  assoc := classVars associationAt: aSymbol otherwise: nil. 
  ].
^ assoc
%

category: 'Reloading Decompiled Methods'
method: Behavior
_resolveClassOrPoolVar: aSymbol

"Searches the receiver's class variables dictionary and pool dictionaries to
 attempt to resolve aSymbol.  Returns the SymbolAssociation for the variable
 with name aSymbol, or nil if aSymbol could not be found."

| assoc |
assoc := self _resolveClassVar: aSymbol .
assoc ~~ nil ifTrue:[ ^ assoc ].

poolDictionaries size > 0 ifTrue:[
  1 to: poolDictionaries size do:[:j | | aDict |
    aDict := poolDictionaries at: j .
    assoc := aDict associationAt: aSymbol otherwise: nil .
    assoc ~~ nil ifTrue:[ ^ assoc ].
    ]. 
  ].
^ nil
%

! fix bug 11618
category: 'Reloading Decompiled Methods'
method: Behavior
_resolveLiteralVar: aSymbol

"Attempts to resolve a literal variable with name aSymbol.  To attempt to
 resolve aSymbol, searches the receiver's class variable dictionary and its pool
 dictionaries, then the superclasses' class variables, then the current default
 SymbolList.

 Returns the SymbolAssociation for the variable or nil if aSymbol could not be
 found."

"Implementation here must agree with comgen.c:searchClassOrPool()"

| assoc aClass |

aClass := self .
"search receiver's class variables and pool variables"
assoc := aClass _resolveClassOrPoolVar: aSymbol . 
assoc ~~ nil ifTrue:[ ^ assoc ].

"search for a class variable inherited from superclasses"
[ (aClass := aClass superclass) ~~ nil 
 ]  
whileTrue: [
  assoc := aClass _resolveClassVar: aSymbol . 
  assoc ~~ nil ifTrue:[ ^ assoc ].
] .
"search the symbol list"
^ GsSession currentSession resolveSymbol: aSymbol
%

! deleted convRecompileWith:

category: 'Private'
method: Behavior
_isKernel

"Private.  Returns true if the given class is a GemStone kernel class."

<primitive: 480>
self _primitiveFailed: #_isKernel
%

category: 'Private'
method: Behavior
_validatePrivilege

System myUserProfile _validateCodeModificationPrivilege

%

category: 'Accessing the Class Format'
method: Behavior
instancesNonPersistent

"Metaclasses are always persistent.  See also reimplementation in Class."
^ false 
%

category: 'Accessing the Class Format'
method: Behavior
instancesDbTransient

"Metaclasses are never DbTransient.  See also reimplementation in Class."
^ false 
%

category: 'Pragmas'
method: Behavior
pragmasForMethod: selector
        "Need to install SessionMethod support to access Pragmas"

        ^#()
%
