!=========================================================================
! Copyright (C) VMware, Inc. 1986-2011.  All Rights Reserved.
!
! $Id: class.gs,v 1.40.2.4 2008-03-04 19:03:19 dhenrich Exp $
!
! Superclass Hierarchy:
!   Class, Behavior, Object.
!
!=========================================================================

removeallmethods Class
removeallclassmethods Class

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

| doc txt |
doc := GsClassDocumentation newForClass: self.
txt := (GsDocText new) details:
'Each of the classes in the GemStone kernel inherits some of its behavior from
 Class.

 You may send the messages described here to any of the kernel classes
 (class-defining objects) defined in this manual.  However, you may not send
 these messages to instances of the kernel classes (that is, unless the
 receiver is an instance of Class).

 Consider the following example.  The description of class SmallInteger
 contains two kinds of protocol: instance methods and class methods.  Instance
 methods are understood by SmallIntegers (instances of the class SmallInteger,
 which inherit their protocol from Integer, Number, Magnitude, and Object).
 Class methods are understood by the class-defining object SmallInteger itself
 (which is the single instance of the Metaclass "SmallInteger class", and
 inherits its protocol from Class, Behavior, and Object).  The messages
 described here (for Class) are understood by SmallInteger; that is, they are
 class methods for the class-defining object), but are not understood by
 instances of SmallInteger.'.
doc documentClassWith: txt.

txt := (GsDocText new) details:
'The class''s name for itself; a Symbol of up to 64 Characters.'.
doc documentInstVar: #name with: txt.

txt := (GsDocText new) details:
'The ClassHistory to which the class belongs.  Every class belongs to exactly
 one class history, which tracks its ancestry and assists with changes to its
 structure (schema).  When a new class is created, it is considered to be either
 a new version of an existing class, or else it has no previous history.  A new
 class version becomes the most recent version in an existing ClassHistory.
 Otherwise, a new ClassHistory is created for the new class.'.
doc documentInstVar: #classHistory with: txt.

txt := (GsDocText new) details:
'Any object, usually an instance of GsClassDocumentation, that describes the
 class.  It can be modified with the description: message.'.
doc documentInstVar: #description with: txt.

txt := (GsDocText new) details:
'A Class, generally considered to be the next later version of this class.  At
 an appropriate time, it may be desirable or necessary to migrate instances of
 this class to the newer version.  This variable remembers which class the
 instance should migrate to.

 You can mark a Class with a migration destination by sending it the message
 migrateTo:.  When so marked, instances of that Class can be migrated to the
 new Class while maintaining identity.  The destination Class should have the
 method migrateFrom: implemented to define the transformation.  A default
 implementation is provided in Object.

 Migration is triggered manually by sending the message migrate to an instance
 of the Class.  Other protocol for forcing migration is
 Class | migrateInstancesTo: and Repository | migrateInstancesOfClasses:.'.
doc documentInstVar: #migrationDestination with: txt.

txt := (GsDocText new) details:
'A DateTime object that indicates when the class was created.'.
doc documentInstVar: #timeStamp with: txt.

txt := (GsDocText new) details:
'A CharacterCollection that gives the identity of the user that created the
 class.'.
doc documentInstVar: #userId with: txt.

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

txt := (GsDocText new) details:
'A CharacterCollection that names the category of classes to which this class
 belongs.  Each subclass also belongs to this category, unless the subclass
 overrides it with its own category.  Class categorization can be used by
 browsers and schema design tools.'.
doc documentInstVar: #classCategory with: txt.

txt := (GsDocText new) details:
'An IdentitySet of the subclasses of this class.  This set is only present in
 modifiable classes, and is nil otherwise.' .
doc documentInstVar: #subclasses with: txt.

txt := (GsDocText new) details:
'Methods in this category are obsolete and are provided only for compatibility
 with earlier releases of GemStone.  They will be removed in a future release.'.
doc documentCategory: #'Backward Compatibility' with: txt.

txt := (GsDocText new) details:
'Every new GemStone Smalltalk class must be a subclass of some other existing
 GemStone Smalltalk class.  To create the new class, you send a subclass
 creation message to its intended superclass.

 The following restrictions apply to creating classes:

 * The new class must be of the same implementation (storage format) as the
   receiver (its superclass), unless the receiver is a non-indexable pointer
   object.  In this case, there are no restrictions if the receiver has no
   instance variables.  If the receiver does have instance variables, the new
   class may not be of special or byte format.
 * The name of a class is a Symbol at most 64 Characters long.
 * The name of an instance variable is a String at most 64 Characters long.
 * A class contains at most 255 named instance variables.

 Implementation Format.

 Instance variables may be named or unnamed.  The class definition (often in
 the subclass creation method) explicitly declares the name and number of all
 named instance variables.  This definition must be fixed (class not
 modifiable) before instances of the class can be created.  The class
 definition also implicitly declares unnamed instance variables (if they
 exist), by the choice of implementation format.  Unnamed variables can vary in
 number independently for each instance.  Depending upon format, unnamed
 variables may be indexed (in which case they are accessed by index), or not
 (in which case they are unordered and are accessed associatively, by value).
 Classes in byte format have indexed instance variables that are stored by byte
 for efficiency of storage and access.

 You use different methods to create a byte class, an indexable class, or a
 class of another format.  For each of these possibilities there is a pair of
 standard methods.  Each of these methods provides a full (long) list of
 keywords that permit you to specify a new class fully.  One of them also
 allows you explicitly to specify the new class as a version of an existing
 class, while the other does not.  Additional methods provide selected shorter
 lists of keywords for convenience, and supply default values for some
 arguments.

 Pool dictionaries.

 If you want to add or remove pool dictionaries for the new class at some
 later time, the argument that supplies the Array of pool dictionaries must not
 be an Array literal.  The literal value produces an InvariantArray object,
 which cannot subsequently be modified.

 Dictionary.

 GemStone adds the new class to a dictionary.  The dictionary is typically
 already in the current user''s symbol list, but it can be added to the symbol
 list at a later time if it is not already there.  (The symbol list makes the
 class visible to the user.)  The specified dictionary is often UserGlobals,
 but may be Globals if the data curator has authorized the user to modify that
 dictionary.

 Constraints.

 Constraints are not supported in GemStone/S 64 Bit. They may still be
 specified via the old method keywords, but the settings are ignored.

 Invariance.

 The invarBoolean argument of a subclass creation method deals with class-level
 invariance.  When that argument is true, GemStone thereafter forces all
 instances of the new class to become invariant as soon as they are committed
 to GemStone.  That is, invariance applies to all objects of that class.

 If instances of the new class''s superclass are invariant, then instances of
 the new class must also be invariant.  In this case, a subclass creation
 method generates an error if the invarBoolean argument is not true.

 Class Modification.

 The modifyBoolean argument of a subclass creation method deals with
 object-level invariance, the ability to modify the object that is the class
 itself.

 Classes are typically not modifiable.  As a result, this argument is generally
 given the value false.  The subclass creation method then makes the new class
 an invariant object, and instances of that class can be created at any time
 after.

 When the modifyBoolean argument is true, the new class is modifiable, not
 invariant.  Its constraints and instance variables can be modified.  However,
 no instances of it can yet be created.  Once all desired changes have been
 made, you must send the new class the message immediateInvariant.  That
 message then makes the new class an invariant object, and no further changes
 to it are possible.  However, instances of the class can then be created.

 For more information about invariance at all levels, see the GemStone
 Programming Guide.

 Classes and Schema.

 A class can be viewed as an implementation of a schema, or of part of a
 schema.  In order to define and develop a schema, you may create modifiable
 classes, which remain modifiable until the schema is stable.

 However, it is sometimes also necessary to change schema after classes are no
 longer modifiable, and after instances of them exist.  To accomplish this kind
 of change, you must create new classes to implement the new schema.  However,
 it may be desirable to consider a new class to be a new version of an existing
 class, so that a logical connection between them and their instances can be
 maintained.

 Speaking conceptually, a class history lists all the versions of a class.
 Speaking technically, the objects that are classes do not have versions.
 Versions are represented by the list of classes in a class history.  Every
 class (object) belongs to exactly one class history; therefore, all the
 classes that are listed in a class history share the same class history
 object.

 Subclass methods that have an oldClass argument typically create the new
 class as a new version of oldClass, and the two classes then share the same
 class history.  However, if oldClass is nil, then the new class is no relation
 to any existing class, and it has a new class history.

 When subclass methods that lack the oldClass argument create a new class with
 the same name as another class that is visible to the user, then the new class
 is a new version of the existing class, and they share the same class history.
 However, if no existing class of this name is visible to the user, then the
 new class is no relation to any existing class, and it has a new class
 history.'.
doc documentCategory: #'Subclass Creation' with: txt.

self description: doc.
%

category: 'Accessing'
method: Class
classHistory

"Returns the classHistory instance variable for this class."

^ classHistory
%

category: 'Accessing'
method: Class
description

"Returns the description instance variable of this class."

^ description
%

category: 'Accessing'
method: Class
migrationDestination

"Returns the migrationDestination instance variable of this class."

^ migrationDestination
%

category: 'Accessing'
method: Class
name

"Returns the receiver's name (the contents of the name instance variable)."

^ name
%

category: 'Accessing'
method: Class
timeStamp

"Returns the timestamp instance variable of this class, a DateTime showing when
 the class was created."

^ timeStamp
%

category: 'Accessing'
method: Class
userId

"Returns the userId instance variable of this class, the ID of the user who
 created this class."

^ userId
%

category: 'Browser Methods'
method: Class
_constraintCreationExpression

"Obsolete in 2.1.
 Returns a string that contains cascaded messages to add constraints to the
 receiver's instance variables."

  | result lfsp aConstraint ivs ivns |

  result := String new.
  lfsp := (Character lf asString) addAll: '  '.

  "hacks for the completely hacked up instance variable scheme in
   GemStone's IdentityBag class"
  ivs := instVars.
  ivns := instVarNames.
  (self isBytes) ifFalse: [
    (constraints isKindOf: Array) ifTrue: [
      1 to: ivs do: [ :x |
        aConstraint := constraints at: x.
        ( ((aConstraint ~~ nil _and: [aConstraint ~~ Object]) 
             _and:[ superClass ~~ nil ])
             _and:[ (superClass _namedIvConstraintAt: x) ~~ aConstraint ])
        ifTrue: [
          (result size > 0 _and: [(result last = $;) not]) ifTrue: [
            result add: $;; addAll: lfsp.
          ].
          result addAll: 'instVar: ';
            addAll: (ivns at: x) quoted;
            addAll: ' constrainTo: ';
            addAll: aConstraint name.
        ].
      ].
      aConstraint:= self varyingConstraint.
      ( (aConstraint ~~ Object) _and:
          [(superClass varyingConstraint) ~~ aConstraint] )
      ifTrue: [
        (result size > 0 _and: [(result last = $;) not]) ifTrue: [
          result add: $;; addAll: lfsp.
        ].
        result addAll: 'varyingConstraint: ';
          addAll: aConstraint name.
      ]
    ]
    ifFalse: [
      constraints class class == Metaclass ifTrue: [
        result addAll: 'varyingConstraint: ';
          addAll: constraints name.
      ]
    ].
  ].
  ^result
%

category: 'Browser Methods'
method: Class
_constraintCreationExpressionIn: dict

"Returns a string that contains cascaded messages to add constraints
 to the receiver's instance variables.  Names of classes are taken from
 the argument, a dictionary."

  | result lfsp aConstraint ivs ivns nm |

  result := String new.
  lfsp := (Character lf asString) addAll: '  '.

  "hacks for the completely hacked up instance variable scheme in
   GemStone's IdentityBag class"
  ivs := instVars.
  ivns := instVarNames.
  (self isBytes) ifFalse: [
    (constraints isKindOf: Array) ifTrue: [
      1 to: ivs do: [ :x |
        aConstraint := constraints at: x.
        (((aConstraint ~~ nil _and: [aConstraint ~~ Object]) 
           _and:[ superClass ~~ nil])
           _and:[ (superClass _namedIvConstraintAt: x) ~~ aConstraint ] )
        ifTrue: [
          (result size > 0 _and: [(result last = $;) not]) ifTrue: [
            result add: $;; addAll: lfsp.
          ].
          nm := dict keyAtValue: aConstraint ifAbsent: [ nil ].
          nm == nil ifTrue: [ nm := aConstraint nameForFileout ].
          result addAll: 'instVar: ';
            addAll: (ivns at: x) quoted;
            addAll: ' constrainTo: ';
            addAll: nm.
        ].
      ].
      aConstraint:= self varyingConstraint.
      ( (aConstraint ~~ Object) _and:
          [(superClass varyingConstraint) ~~ aConstraint] )
      ifTrue: [
        (result size > 0 _and: [(result last = $;) not]) ifTrue: [
          result add: $;; addAll: lfsp.
        ].
        nm := dict keyAtValue: aConstraint ifAbsent: [ nil ].
        nm == nil ifTrue: [ nm := aConstraint nameForFileout ].
        result addAll: 'varyingConstraint: ';
          addAll: nm.
      ]
    ]
    ifFalse: [
      constraints class class == Metaclass ifTrue: [
        nm := dict keyAtValue: constraints ifAbsent: [ nil ].
        nm == nil ifTrue: [ nm := constraints nameForFileout ].
        result addAll: 'varyingConstraint: ';
          addAll: nm.
      ]
    ].
  ].
  ^result
%

! final implementation of _sortedClassVarNames is in class2.gs
!  this implementation is used during filein only
category: 'Private'
method: Class
_sortedClassVarNames

"Return an unsorted list because the image is still being bootstrapped."
  ^ classVars keys
%

category: 'Browser Methods'
method: Class
_definitionInContext: aUserProfile

"Returns a description of the receiver using object names taken from the given
 UserProfile."

| result newByteSubclass anArray lfsp
  aConstraint firstElement inv civs |

result := String new.
result addAll: (superClass == nil ifTrue: ['nil'] ifFalse: [superClass name]).

newByteSubclass := false.
lfsp := (Character lf asString) addAll: '  '; yourself.


(self isBytes _and: [superClass isBytes not]) ifTrue: [
  result addAll: ' byteSubclass: '''; addAll: name; addLast: $'.
  newByteSubclass := true.
]
ifFalse: [
  (self isIndexable _and: [superClass isIndexable not]) ifTrue: [
    result addAll: ' indexableSubclass: '''; addAll: name; addLast: $'.
  ]
  ifFalse: [
    result addAll: ' subclass: '''; addAll: name; addLast: $'.
  ]
].

" instVarNames: #( <list of strings> ) "

newByteSubclass ifFalse: [
  result addAll: lfsp;
    addAll: 'instVarNames: #(';
    addAll: (self _instVarNamesWithSeparator: (lfsp , '                 '));
    add: $).
].

" classVars: #( <list of strings> ) "
result addAll: lfsp; addLast: 'classVars: #('.
self _sortedClassVarNames do: [:aKey |
  result addLast: $  . 
  (aKey includesValue: $') 
    ifTrue:[ result addAll: aKey _asSource ]
    ifFalse:[ result addAll: aKey ].
  ].
result addLast: $).

" classInstVars: #( <list of strings> ) "

result addAll: lfsp; addLast: 'classInstVars: #('.
civs := self class allInstVarNames.
civs removeFrom: 1 to: (self class superClass instSize).
civs do: [:civName |
  result addLast: $  .
  (civName includesValue: $') 
    ifTrue:[ result addAll: civName _asSource ]
    ifFalse:[ result addAll: civName ].
].
result addLast: $).

" poolDictionaries: #[ <list of dictionary names> ] "

inv := poolDictionaries isKindOf: InvariantArray.
result addAll: lfsp; addAll: 'poolDictionaries: #'.

result add: (inv ifTrue: [ $( ] ifFalse: [ $[ ]).

firstElement := true.
self sharedPools do: [:each |
  firstElement ifFalse: [ result addAll: ', '].  "separate with commas"
  anArray := aUserProfile dictionaryAndSymbolOf: each.
  anArray == nil
        ifTrue: [ result addAll: ' "(not named)" ' ]
        ifFalse: [ result addAll: (anArray at: 2)].
  firstElement := false.
].

result add: (inv ifTrue: [ $) ] ifFalse: [ $] ]).

" inDictionary: <name of containing dictionary> "

result addAll: lfsp; addAll: 'inDictionary: '.
anArray := aUserProfile dictionaryAndSymbolOf: self.
anArray == nil ifTrue: [
  result addAll: '(class not in your dictionaries)'
]
ifFalse: [
  anArray := aUserProfile dictionaryAndSymbolOf: (anArray at: 1).
  anArray == nil ifTrue: [
    result addAll: '(dictionary not in your dictionaries)'
  ]
  ifFalse: [
    result addAll: (anArray at: 2)
  ]
].

" constraints: #[ <Array of instance-variable-symbol/class-name pairs> ]
    or
  constraints: <class name> "

newByteSubclass ifFalse: [
  result addAll: lfsp; addAll: 'constraints: '.
  (constraints isKindOf: Array ) ifTrue: [
    result addAll: '#[ '.
    firstElement := true.
    1 to: instVars do: [ :x |
      aConstraint := constraints at:x .
      ((aConstraint ~~ nil _and: [aConstraint ~~ Object]) 
          _and:[ superClass == nil 
            _or:[ (superClass _namedIvConstraintAt: x) ~~ aConstraint ]] )
      ifTrue: [
        " if not the first constraint, prefix with a comma to separate
          from the last constraint "
        firstElement ifFalse: [
          result addLast: $,; addAll: lfsp; addAll: '                '
        ]
        ifTrue: [
          firstElement := false
        ].
        result addAll: '#[ #'; addAll: (instVarNames at: x) ;
              addAll: ', '; addAll: aConstraint name; addLast: $] .
      ]
    ].
    aConstraint:= self varyingConstraint .
    ( (aConstraint ~~ Object) _and:
        [(superClass varyingConstraint) ~~ aConstraint] )
    ifTrue:[
      firstElement ifFalse: [
          result addLast: $,; addAll: lfsp; addAll: '                '
      ]
      ifTrue: [
        firstElement := false
      ].
      result addAll: '   "the elements"  '; addAll: aConstraint name
    ].
    result addAll: ' ]'.
  ]
  ifFalse: [
    constraints class class == Metaclass ifTrue: [
      result addAll: constraints name.
    ]
    ifFalse: [
      result addAll: ' nil'
    ].
  ].

    " instancesInvariant: "

  result addAll: lfsp;
    addAll: 'instancesInvariant: ';
    addAll: (self instancesInvariant describe).

    " instancesInvariant: aBoolean "

  result addAll: lfsp;
    addAll: 'isModifiable: '; addAll: (self isModifiable describe).
]
ifTrue: [ "a Byte subclass"

    " instancesInvariant: aBoolean "                           "fix 9763"

  result addAll: lfsp;
    addAll: 'instancesInvariant: '; addAll: (self instancesInvariant describe).
].

result add: Character lf.
^result
%

! fix bug 13090
category: 'Browser Methods'
method: Class
_instVarNamesWithSeparator: sep

"Returns a string showing my instance variables, with the given
 separator string inserted after every three names."

| result i theIvs numIvs each |

result := String new: 0.
i := 0.
theIvs := self instVarNames.
numIvs := theIvs size.
1 to: numIvs do:[:j|
  each := theIvs at: j .
  (i := i + 1) > 3 ifTrue:
    [
    result addAll: sep.
    i := 0.
    ].
  result addLast: $  .
  (each includesValue: $') 
    ifTrue:[ result addAll: each _asSource ]
    ifFalse:[ result addAll: each ].
  ].
^result
%

category: 'Browser Methods'
method: Class
_modifiableDefinitionInDictionary: dict named: dictName

"Returns a description of the receiver that is modifiable, contains no
 constraints, and that places the class in the given dictionary name.
 Byte classes will not use the modifiable form of class definition as
 they have no information that can be modified."

  | result newByteSubclass lfsp
    firstElement inv cat nm resolver |

  nm := superClass == nil ifTrue: [ 'nil' ] ifFalse: [
      dict keyAtValue: superClass ifAbsent: [ superClass nameForFileout ]
      ].
  result := String new add: $( ; addAll: nm ; yourself .
  newByteSubclass := false.
  lfsp := (Character lf asString) addAll: '  '.

  (self isBytes _and: [superClass isBytes not]) ifTrue:
    [
    result addAll: ' byteSubclass: '.
    newByteSubclass := true.
    ]
  ifFalse:
    [
    (self isIndexable _and: [superClass isIndexable not]) ifTrue:
      [ result addAll: ' indexableSubclass: ' ]
    ifFalse:
      [ result addAll: ' subclass: ' ].
    ].

  nm := dict keyAtValue: self ifAbsent: [ self nameForFileout ].
  result addAll: (String withAll: nm) quoted.

 " instVarNames: #( <list of strings> ) "
  newByteSubclass ifFalse: [
    result addAll: lfsp;
      addAll: 'instVarNames: #(';
      addAll: (self _instVarNamesWithSeparator: (lfsp , '                 '));
      add: $).
  ].

  " classVars: #( <list of strings> ) "

  result addAll: lfsp; addLast: 'classVars: #('.
  self _sortedClassVarNames do: [:aKey |
    result addLast: $  . 
    (aKey includesValue: $') 
      ifTrue:[ result addAll: aKey _asSource ]
      ifFalse:[ result addAll: aKey ].
    ].

  result addLast: $).

  " classInstVars: #( <list of strings> ) "

  result addAll: lfsp; addLast: 'classInstVars: #('.
  self _classInstVars do:[:civName |
    result addLast: $  .
    (civName includesValue: $') 
      ifTrue:[ result addAll: civName _asSource ]
      ifFalse:[ result addAll: civName ].
    ].
  result addLast: $).

  " poolDictionaries: #[ <list of dictionary names> ] "

  inv := poolDictionaries isKindOf: InvariantArray.
  result addAll: lfsp; addAll: 'poolDictionaries: #'.

  inv ifTrue:
    [result add: $(]
  ifFalse:
    [result add: $[].

  firstElement := true.
  resolver := System myUserProfile .
  self sharedPools do: [:each | | anArray |
    anArray := resolver dictionaryAndSymbolOf: each.
    anArray == nil ifTrue: [
      result addAll: ' "(not named), " '
    ]
    ifFalse: [
      firstElement ifFalse: [ result addAll: ', '].  "separate with commas"
      result addAll: (anArray at: 2)
    ].
    firstElement := false.
  ].

  inv ifTrue:
    [result add: $)]
  ifFalse:
    [result add: $]].

  " inDictionary: <name of containing dictionary> "

  result addAll: lfsp; addAll: 'inDictionary: '; addAll: dictName.

  "constraints: #[ <Array of instance-variable-symbol/class-name pairs> ]
     or
   constraints: <class name> "

  newByteSubclass ifFalse:
    [
    result addAll: lfsp; addAll: 'constraints: '.
    (constraints isKindOf: Array ) ifTrue:
      [
      result addAll: '#[]'.
      ]
    ifFalse:
      [
      result addAll: ' Object'.
      ].
    ].

  result addAll: lfsp; addAll: 'instancesInvariant: '; addAll:
        (self instancesInvariant ifTrue: [ 'true' ] ifFalse: [ 'false' ]).

  newByteSubclass ifFalse:
    [ result addAll: lfsp; addAll: 'isModifiable: true' ].


  result add: $).
  self subclassesDisallowed ifTrue: [
    result addAll: ' disallowSubclasses '
  ].
  cat := classCategory .
  cat ~~ nil ifTrue: [
    result last = $) ifFalse: [ result addAll: ';
 '
    ].
    result addAll: ' category: '; addAll: (String withAll: cat) quoted
  ].
  result addLast: Character lf .
  ^result
%

category: 'Category'
method: Class
_classCategory 

"Returns the classCategory of the receiver."

^ classCategory
%

category: 'Category'
method: Class
category: newCategory

"Sets the classCategory variable of the receiver.
 The argument should be a kind of CharacterCollection or nil."

| s |
(s := self _primitiveSize) < Class instSize ifTrue:[
  "Grow an instance that originated in a 4.1 GemStone repository"
  s + 1 to: Class instSize do:[:j | self _unsafeAt: j put: nil ].
  ]. 
newCategory ~~ nil ifTrue:[ newCategory _validateClass: CharacterCollection ].
classCategory := newCategory 
%

category: 'Modifying Classes'
method: Class
_subclasses

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

^ subclasses
%

category: 'Modifying Classes'
method: Class
_subclasses: anIdentitySet 

"Modifies the class variable that is the list of subclasses."

| s |
self _validatePrivilege.
(s := self _primitiveSize) < Class instSize ifTrue:[
  "Grow an instance that originated in a 4.1 GemStone repository"
  s + 1 to: Class instSize do:[:j | self _unsafeAt: j put: nil ].
  ]. 
anIdentitySet ~~ nil ifTrue:[ anIdentitySet _validateClass: IdentitySet ].
subclasses := anIdentitySet
%

category: 'Browser Methods'
method: Class
_superClassHierarchy

"Returns a string showing the superClass hierarchy of the receiver."

| result lf count |

result := String new: 0.
lf := Character lf.
count := 0.
(self _allSuperList addLast: self; yourself) do: [:each | | instString |
   1 to: count do: [:i | result addAll: '  '].
   instString := each _instVarNamesWithSeparator:  ''   .
   instString size > 0 ifTrue:
     [
     " if the class has instance variables, include them in parentheses "
     result addAll: each name;
            addLast: $(; addAll: instString; addLast: $);
            addLast: lf.
     ]
   ifFalse:
     [
     result addAll: each name; addLast: lf.
     ].
   count := count + 1
   ].
^result
%

category: 'Browser Methods'
method: Class
changeNameTo: newInternalName

"Sets the receiver's 'name' instance variable."

| isInvariant newName |

self _validatePrivilege.
isInvariant := self isInvariant.
newName := Symbol withAll: newInternalName.
newInternalName size > 0 ifFalse: [
  self error:'class names must have size > 0' .  
  ^ self .
].
isInvariant ifTrue: [ self __makeVariant ].
name := newName.
isInvariant ifTrue: [ self immediateInvariant ].
%

category: 'Browser Methods'
method: Class
compileMissingAccessingMethods

"Creates accessing and updating methods for all instance variables that do not
 already have such methods."

| argName newLine allVarNames varNames |

self _validatePrivilege.
argName := 'newValue'.
allVarNames := self allInstVarNames.
[allVarNames includesValue: argName] whileTrue: [
  argName := 'z' , argName.
].
newLine:= Character lf asString.
varNames := self instVarNames.
varNames do: [ :var |
  (self includesSelector: var ) ifFalse: [
    self compileMethod: (var , newLine , newLine ,
        '   "Return the value of the instance variable ''' , var ,
        '''."' , newLine , '   ^' , var , newLine)
        dictionaries:  #() 
        category: #Accessing
  ].
  (self includesSelector: var , $: ) ifFalse: [
    self compileMethod: (var , ': ' , argName , newLine , newLine ,
        '   "Modify the value of the instance variable ''' , var ,
        '''."' , newLine , '   ' , var , ' := ' , argName , newLine)
        dictionaries:  #() 
        category: #Updating
  ]
]
%

category: 'Browser Methods'
method: Class
definition

"Returns a String containing a GemStone Smalltalk definition for the receiver
 (that is, a subclass creation message).  This method uses the UserProfile
 of the owner of the current session as the correct context."

"For use with the Topaz run command."

^ self _definitionInContext: System myUserProfile
%

category: 'Browser Methods'
method: Class
hierarchy

"Returns a String that enumerates the receiver's superclasses (up to Object)
 and the instance variables defined by the receiver and each of its
 superclasses."

"For use with the Topaz run command."

^ self _superClassHierarchy
%

category: 'Browser Methods'
method: Class
recompileWithDicts: symbolList

"Recompiles all the receiver's instance and class methods.  Returns the
 CompiledMethods that fail to compile properly."

| failed cls cats |

self _validatePrivilege.
failed := #[].
2 timesRepeat: [
  cls == nil ifTrue: [ cls := self ] ifFalse: [ cls := self class ].
  cats := cls _categories copy .  "workaround for bug 7724"
  cats keysAndValuesDo: [:aKey :aValue | | cat sels |
    cat  := aKey.
    sels := aValue .
    1 to: sels size do: [:s | | sel result |
      sel := sels at: s.
      result := cls compileMethod: (cls sourceCodeAt: sel)
                    dictionaries: symbolList category: cat.
      result == nil ifFalse: [
        failed add: (cls _methodDict at: sel)
      ].
    ].
  ].
].

^failed.
%

category: 'Class Instance Variables'
method: Class
addClassInstanceVariable: civNameString

"Adds the given class instance variable to the receiver's Metaclass.
 Generates an error if the receiver is either not modifiable or does
 not disallow subclasses."

self _validatePrivilege.
self class addInstVarNames: #[civNameString]
%

category: 'Class Instance Variables'
method: Class
atClassInstVar: varName

"Returns the value of the given class instance variable in the receiver.
 Generates an error if the argument does not name a class instance variable
 in the receiver.  In general, it is more efficient to implement a direct
 accessing method for a class instance variable."

| idx cls varSym |
varSym := Symbol _existingWithAll: varName .
varSym == nil ifTrue:[ 
  self _error: #classErrNotAVar args: #[varName] .
  ^ nil
  ].
cls := self class.
idx := cls.instVarNames indexOfValue: varSym.
(idx < 0 _or: [idx <= Metaclass.instVars]) ifTrue: [
  self _error: #classErrNotAVar args: #[varName] .
  ^ nil
].
^self instVarAt: idx
%

category: 'Class Instance Variables'
method: Class
atClassInstVar: varName put: newValue

"Changes the value of the given class instance variable in the receiver,
 without regard to the variance or invariance of the receiver.  Generates an
 error if the argument does not name a class instance variable in the receiver.
 Returns the argument 'newValue'."

| idx cls varSym |
self _validatePrivilege.
varSym := Symbol _existingWithAll: varName .
varSym == nil ifTrue:[ 
  self _error: #classErrNotAVar args: #[varName] .
  ^ nil
  ].

cls := self class.
idx := cls.instVarNames indexOfValue: varSym.
(idx < 0 _or: [idx <= Metaclass.instVars]) ifTrue: [
  self _error: #classErrNotAVar args: #[varName].
  ^newValue
].
(newValue isKindOf: (cls.constraints at: idx)) ifFalse: [
  self _error: #objErrConstraintViolation args:
    #[self,newValue,(cls.constraints at: idx),newValue class].
  ^newValue
].
self _unsafeAt: idx put: newValue.
^newValue
%

category: 'Clustering'
method: Class
clusterDepthFirst

"Clusters elements of the receiver and its Metaclass that are used
 for GemStone Smalltalk execution, then Clusters elements of the receiver 
 and its Metaclass that are not required for GemStone Smalltalk execution."

self clusterBehavior ifTrue:[ ^ true ].
self clusterDescription .
^ false
%

category: 'Clustering'
method: Class
clusterBehavior

"Clusters elements of the receiver and its Metaclass that are used
 for GemStone Smalltalk execution.

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

super clusterBehavior ifTrue:[ ^ true ].
self class clusterBehavior .
^ false
%

category: 'Clustering'
method: Class
clusterDescription

"Clusters elements of the receiver and its Metaclass that are not required
 for GemStone Smalltalk execution.  

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

super clusterDescription ifTrue:[ ^ true ].
self class clusterDescription .
^ false
%


category: 'Displaying'
method: Class
instanceString

"Returns a symbol that can be used to name an instance of the receiver."

^(('AEIOUYaeiouy' indexOf: (name at: 1) startingAt: 1) > 0
   ifTrue: ['an']
   ifFalse: ['a'])
 , name
%

category: 'Displaying'
method: Class
instanceSymbol

"Returns a symbol that can be used to name an instance of the receiver."

^ ((('AEIOUYaeiouy' indexOf: (name at: 1) startingAt: 1) > 0
  ifTrue: ['An']
  ifFalse: ['A'])
    , name) asSymbol
%

! _isSubclassDisallowed no longer exists in 4.0.  All disallowing of
!  subclasses is done with the format bit.  See bomnew.gs

category: 'Filein Support'
method: Class
_newKernelByteSubclass: clsName
classVars: classVarArg
poolDictionaries: poolDicts
inDictionary: aDict
instancesInvariant: aBool
reservedOop: reservedOopNum

"Old (v 2G) behavior: 
   Created a new class always, to allow upgrade
   scripts to change the definition of a kernel class.  Preserved
   the identity of both the class and the metaClass if the class
   already existed.

 New (Gemstone64) behavior:  
   Does not allow redefinition of a
   class in the upgrade case.  Only create class if it does not exist
   by the given name in globals.  The _unsafeSet11Oop primitive does
   not currently allow changing the identity of an already existing
   object.

 Returns a String, either the definition of the new class or a
 message that the class already exists.

 If reservedOopNum is ~~ nil, reservedOopNum must be a positive Integer
 that is a legal gs64v1.1 objectId and the methods   Object >> _unsafeSet11Oop: 
 and   Object(C) >> _objectForOop:   must be installed."

| newClass className oldCls resolveRes |

self _validatePrivilege.
aDict == Globals ifFalse:[
  aDict _error: #rtErrInvalidArgument .
  ^ false ] .

className := Symbol withAll: clsName .

resolveRes := Class _resolveReservedClass: reservedOopNum name: className .
oldCls := resolveRes at: 1 .
oldCls == nil ifTrue:[ 
  Segment setCurrent: Object segment while:[

    newClass := self byteSubclass: className
      classVars: classVarArg
      classInstVars: nil
      poolDictionaries: poolDicts
      inDictionary: aDict
      description: nil
      isInvariant: aBool .
  
    reservedOopNum ~~ nil ifTrue:[    
       newClass := newClass _unsafeSet11Oop: reservedOopNum .
    ].
  ].
].
^ self _finishNewReservedClass: newClass old: oldCls resolv: resolveRes
 
%

category: 'Filein Support'
method: Class
_newKernelIndexableSubclass: clsName
instVarNames: ivArg
classVars: classVarArg
classInstVars: classInstVarArg
poolDictionaries: poolDicts
inDictionary: aDict
constraints: constrArray
instancesInvariant: aBool
isModifiable: modBool
reservedOop: reservedOopNum

"Old (v 2G) behavior: 
   Created a new class always, to allow upgrade
   scripts to change the definition of a kernel class.  Perserved
   the identity of both the class and the metaClass if the class
   already existed.

 New (Gemstone64) behavior:  
   Does not allow redefinition of a
   class in the upgrade case.  Only create class if it does not exist
   by the given name in globals.  The _unsafeSet11Oop primitive does
   not currently allow changing the identity of an already existing
   object.

 Returns a String, either the definition of the new class or a
 message that the class already exists.

 If reservedOopNum is ~~ nil, reservedOopNum must be a positive Integer
 that is a legal gs64v1.1 objectId and the methods   Object >> _unsafeSet11Oop: 
 and   Object(C) >> _objectForOop:   must be installed."

| newClass className oldCls resolveRes |
self _validatePrivilege.
aDict == Globals ifFalse:[
  aDict _error: #rtErrInvalidArgument .
  ^ false ] .

className := Symbol withAll: clsName .

resolveRes := Class _resolveReservedClass: reservedOopNum name: className .
oldCls := resolveRes at: 1 .
oldCls == nil ifTrue:[ 

  Globals at: className put: nil.
  Segment setCurrent: Object segment while:[

    newClass := self indexableSubclass: className
      instVarNames: ivArg
      classVars: classVarArg
      classInstVars: classInstVarArg
      poolDictionaries: poolDicts
      inDictionary: aDict
      constraints: constrArray
      instancesInvariant: aBool
      description: nil
      isModifiable: modBool.
  
    reservedOopNum ~~ nil ifTrue:[
      "change object identifier"
      newClass := newClass _unsafeSet11Oop: reservedOopNum .
    ].
  ].
].
^ self _finishNewReservedClass: newClass old: oldCls resolv: resolveRes
%

category: 'Filein Support'
classmethod: Class
_resolveReservedClass: reservedOopNum name: className

  " returns an Array of size 2.  
     result at:1 is already existing class or nil .
     result at: 2 is a String describing Globals modifications made"

  | oldCls result |
  result := Array new: 2 .
  result at: 2 put: String new .
  reservedOopNum ~~ nil ifTrue:[ | resOop20 |
    resOop20 := Object _oop11toOop20: reservedOopNum .
    oldCls := Object _objectForOop: resOop20 .
    oldCls ~~ nil ifTrue:[
      "ensure referenced from Globals"
      Globals at: className ifAbsent:[ 
         Globals at: className put: oldCls .
         result at:2 put: (className asString , ' re-added to Globals').
      ].
    ]
  ]
  ifFalse:[
    oldCls := Globals at: className otherwise: nil .
  ].
  result at:1 put: oldCls .
  ^ result
%
category: 'Filein Support'
method: Class
_finishNewReservedClass: newClass old: oldCls resolv: resolveRes
  oldCls == nil ifTrue:[ 
    (((newClass _class) superclass) == (self _class)) ifFalse:[ 
       self _halt: 'Inconsistent class hierarchy' 
    ].
     ^ 'created class: '  , newClass definition 
   ]
   ifFalse:[ ^ 'class already exists: ' , (resolveRes at: 2)
	    , ', ' , oldCls definition 
   ].
%

category: 'Filein Support'
method: Class
_newKernelSubclass: clsName
instVarNames: ivArg
classVars: classVarArg
classInstVars: anArrayOfClassInstVars
poolDictionaries: poolDicts
inDictionary: aDict
constraints: constrArray
instancesInvariant: aBool
isModifiable: modBool
reservedOop: reservedOopNum

"Old (v 2G) behavior: 
   Created a new class always, to allow upgrade
   scripts to change the definition of a kernel class.  Preserved
   the identity of both the class and the metaClass if the class
   already existed.

 New (Gemstone64) behavior:  
   Does not allow redefinition of a
   class in the upgrade case.  Only create class if it does not exist
   by the given name in globals.  The _unsafeSet11Oop primitive does
   not currently allow changing the identity of an already existing
   object.
 
 Returns a String, either the definition of the new class or a
 message that the class already exists.

 If reservedOopNum is ~~ nil, reservedOopNum must be a positive Integer
 that is a legal gs64v1.1 objectId and the methods   Object >> _unsafeSet11Oop: 
 and   Object(C) >> _objectForOop:   must be installed."

| newClass className oldCls resolveRes |

self _validatePrivilege.
aDict == Globals ifFalse:[
  aDict _error: #rtErrInvalidArgument .
  ^ false ] .

className := Symbol withAll: clsName .

resolveRes := Class _resolveReservedClass: reservedOopNum name: className .
oldCls := resolveRes at: 1 .
oldCls == nil ifTrue:[ 

  Globals at: className put: nil.
  Segment setCurrent: Object segment while:[
    newClass := self subclass: className
      instVarNames: ivArg
      classVars: classVarArg
      classInstVars: anArrayOfClassInstVars
      poolDictionaries: poolDicts
      inDictionary: aDict
      constraints: constrArray
      instancesInvariant: aBool
      description: nil
      isModifiable: modBool.
  
    reservedOopNum ~~ nil ifTrue:[
      "change object identifier"
      newClass := newClass _unsafeSet11Oop: reservedOopNum .
    ].
  ].
].

^ self _finishNewReservedClass: newClass old: oldCls resolv: resolveRes

%

! _redefineKernelSubclass:... not implemented in gemstone64

! fixed 31057
category: 'Instance Migration'
method: Class
allInstances

"Returns an Array that contains all instances of the receiver.

 Note: This method scans the entire GemStone repository, and may therefore
 take some time to execute.

 This method aborts the current transaction; if an abort would cause unsaved
 changes to be lost, it signals an error, #rtErrAbortWouldLoseData."

^ (SystemRepository listInstances: #[self]) at: 1
%

category: 'Instance Migration'
method: Class
cancelMigration

"Disables class migration by clearing the migrationDestination instance
 variable."

self migrationDestination: nil.
%

category: 'Instance Migration'
method: Class
instVarMappingTo: anotherClass

"Returns an instance-variable mapping from the receiver's named instance
 variables to those in the given class.  If an entry is 0, the other
 class does not have the corresponding instance variable."

| otherivn result |
otherivn := anotherClass.instVarNames.
result := Array new: instVars.
1 to: instVars do: [:i |
  result at: i put: (otherivn indexOfValue: (instVarNames at: i))
].
^result
%

category: 'Instance Migration'
method: Class
migrateInstances: instances to: anotherClass

"Migrates each of the instances to anotherClass, using migrateFrom:instVarMap:
 and performing become: operations to accomplish this task.  Removes the
 indexes of indexed instances.  Returns an Array of four Sets of instances,
 none of which were migrated:

 * Objects that you cannot read.  (obsolete - always empty)
 * Objects that you cannot write. (obsolete - always empty)
 * Objects that are in indexed collections that have different formats.
   (For a more detailed description, see Object | become:.)
 * Objects whose class is not identical to the receiver.

 Generates the error errNotSameClassHist if the classHistory of the receiver
 is not identical to the classHistory of anotherClass."

| inst other otherivi noread nowrite inIndex checkidx badClass |

self _validatePrivilege.
"check for legal class histories."
self classHistory == anotherClass classHistory ifFalse:[
  ^ self _error: #errNotSameClassHist args: #[ anotherClass ] .
  ].

noread := IdentitySet new.
nowrite := IdentitySet new.
inIndex := IdentitySet new.
badClass := IdentitySet new .
checkidx := self inheritsFrom: UnorderedCollection.
otherivi := anotherClass instVarMappingTo: self.

Exception
  category: GemStoneError
  number: (ErrorSymbols at: #rtErrCantBecomeOneIdx)
  do: [:ex:cat:num:args | inIndex add: inst ] .

1 to: instances size do: [:i |
  inst := instances _at: i.
  (checkidx _and: [inst _hasIndexes]) ifTrue: [
        inst removeAllIndexes ].
  inst class == self 
  ifFalse:[ badClass add: inst ]
  ifTrue:[
      other := anotherClass _basicNew.
      other migrateFrom: inst instVarMap: otherivi.
      other become: inst.
      ].
    ].
^#[noread, nowrite, inIndex, badClass ]
%

category: 'Instance Migration'
method: Class
migrateInstancesTo: anotherClass

"Finds all instances of the receiver.  Migrates each instance that is
 accessible and whose references are writable to anotherClass, using
 migrateFrom:instVarMap: and performing become: operations to accomplish this
 task.  Removes the indexes of indexed instances.  Returns an Array of four
 Sets of instances, none of which were migrated:

 * Objects that you cannot read.
 * Objects that you cannot write.
 * Objects that are in indexed collections that have different formats.
   (For a more detailed description, see Object | become:.)
 * Objects whose class is not identical to the receiver.

 This method scans the entire GemStone repository, and may therefore take some
 time to execute."

| instances |

self _validatePrivilege.
self classHistory == anotherClass classHistory ifFalse:[
  ^ self _error: #errNotSameClassHist args: #[ anotherClass ] .
  ].
instances := self allInstances.
^self migrateInstances: instances to: anotherClass
%

category: 'Instance Migration'
method: Class
migrateTo: aClass

"Enables class migration by setting the migrationDestination instance
 variable."

self _validatePrivilege.
self migrationDestination: aClass.
%

category: 'Locking'
method: Class
lockableParts

"Returns an Array of the receiver's contents that are locked by browsers
 and folders."

| mcls parts |
mcls := self class.
parts := #[ self,
  instVarNames,
  classVars,
  categories,
  methodDict,
  extraDict,

  mcls,
  mcls.instVarNames,
  "mcls.classVars," "??"
  mcls.categories,
  mcls.methodDict,
  mcls.poolDictionaries ].

^parts
%

category: 'Private'
method: Class
__makeVariant

"Makes the receiver variant."

<primitive: 272>
self _primitiveFailed: #__makeVariant
self _uncontinuableError
%

category: 'Private'
method: Class
_beVariantWhile: aBlock

"Executes the given block while the receiver is in a variant (modifiable) form.
 The block should not contain a return or the receiver will be left in a
 variant state.

 Great caution should be exercised in using this method as it allows
 modification of classes in uncontrolled ways that can lead to corrupted class
 objects."

| was |
self _validatePrivilege.
was := self isInvariant.
was ifTrue: [ self __makeVariant; _refreshClassCache ].
Exception category: nil number: nil do: [:ex:cat:num:args |
  was ifTrue: [ super immediateInvariant; _refreshClassCache ].
  ex resignal: cat number: num args: args.
  was ifTrue: [ self __makeVariant; _refreshClassCache ].
].
aBlock value.
was ifTrue: [ super immediateInvariant; _refreshClassCache ].
%

! gemstone64: renamed _civSizeIncreasedAt: to _insertCivAt: and made primitive
category: 'Private'
method: Class
_insertCivAt: offset

"insert space for a new class instance variable at the specified offset.
 Each call will cause a markSweep GC of the VM local object memory."
 
<primitive: 486>

self _primitiveFailed: #_insertCivAt:
self _uncontinuableError
%

category: 'Private'
method: Class
_gbsTraversalCallback

"Private.  When GemBuilder Smalltalk traverses a Class, this method
 is called to return a description of the class."

^self definition
%

category: 'Queries'
method: Class
isMeta

"Returns whether the receiver is a kind of Metaclass."

^false
%

category: 'Queries'
method: Class
thisClass

"Returns the receiver.  The receiver's Metaclass returns this Class as well.
 This method is useful to get the base version of a Class if one is
 holding either the Class or its Metaclass."

^self
%

category: 'Subclass Creation'
method: Class
_classDefiningClassVar: aSymbol

"Returns the receiver or the superclass that defines a class variable with
 name aSymbol, otherwise returns nil."

| aClass assoc |

aClass := self .
[ 
  assoc := classVars associationAt: aSymbol otherwise: nil.
  assoc ~~ nil ifTrue:[ ^ aClass ].
  aClass := aClass superclass .
  aClass == nil
] untilTrue .
^ nil
%

category: 'Subclass Creation'
method: Class
_makeClassVarDict: anArrayOfClassVars

"Turns Array of class variable names into a SymbolDictionary."

| newDict aVarName aSym definingClass |

self _validatePrivilege.
anArrayOfClassVars _validateClass: Array .
newDict := SymbolDictionary new.
1 to: anArrayOfClassVars size do: [:index|
  aVarName := (anArrayOfClassVars at: index) .
  aVarName _validateClass: CharacterCollection .
  aSym := aVarName asSymbol .
  aSym validateIsIdentifier .                "fix bug 9666"
  definingClass := self _classDefiningClassVar: aSym .  "fix bug 10480"
  definingClass ~~ nil ifTrue:[
    definingClass _error: #classErrClassVarNameExists args: #[ aSym ] .
    self _uncontinuableError .
    ].
  newDict at: aSym put: nil
  ].
^ newDict
%

category: 'Subclass Creation'
method: Class
_nilOrClassNamed: aSymbol

""

| assoc assValue |
(GsCurrentSession == nil _or:[ GsSession currentSession class == Array])
ifTrue:[
  "handle bootstrap of image or image conversion."
   assoc := System myUserProfile symbolList resolveSymbol: aSymbol .
  ]
ifFalse:[ 
  assoc := GsSession currentSession resolveSymbol: aSymbol 
  ].

(assoc ~~ nil _and: [ (assValue := assoc value) isKindOf: Class])
  ifTrue: [ ^ assValue ].
^ nil
%

category: 'Subclass Creation'
method: Class
_subclass: className
instVarNames: anArrayOfStrings
format: theFormat
constraints: theConstraints
classVars: anArrayOfClassVars
classInstVars: anArrayOfClassInstVars
poolDictionaries: anArrayOfPoolDicts
inDictionary: aDictionary
inClassHistory: aClassHistory
description: aDescription
isModifiable: modifyBoolean

"The preferred private subclass creation method."

| cvDict result theName ivNames classCon temp aString conEle conEleEle theHist
  selfClass resultClass poolDicts |
self _validatePrivilege.
className _validateClass: CharacterCollection .
anArrayOfClassInstVars ~~ nil ifTrue:[
  anArrayOfClassInstVars _validateClass: Array . "fix bug 11833"
  ].
theName := className asSymbol.
ivNames := anArrayOfStrings class new.
1 to: anArrayOfStrings size do: [:j |
  aString := anArrayOfStrings at: j .
  ivNames add: aString asSymbol
].
(theConstraints isKindOf: Array)
ifFalse: [ classCon:= theConstraints ]
ifTrue: [
   classCon:= theConstraints class new.
   1 to: theConstraints size do: [:j |
      conEle := theConstraints at: j .
      (conEle isKindOf: Array)
      ifFalse: [ classCon add: conEle ]
      ifTrue: [
         temp:= conEle class new.
         1 to: conEle size do: [:k |
            conEleEle := conEle at: k .
            (conEleEle isKindOf: CharacterCollection)
                 ifTrue: [temp add: conEleEle asSymbol ]
                ifFalse: [temp add: conEleEle].
                     ].
         classCon add: temp .
         ] .
      ] .
  ] .

cvDict:= self _makeClassVarDict: anArrayOfClassVars .

"undo the compiler's canonicalization of empty arrays (fix bug 14103) "
poolDicts := anArrayOfPoolDicts .
poolDicts == #() ifTrue:[ poolDicts := poolDicts copy ].

result :=  aDictionary at: theName
           put:(  self _subclass: theName
                       instVarNames: ivNames
                       format: theFormat
                       constraints: classCon
                       classVars: cvDict
                       poolDictionaries: poolDicts ) .
modifyBoolean ifTrue:[
  result _subclasses: IdentitySet new .
  ] .
subclasses ~~ nil ifTrue:[ subclasses add: result ].

result description: aDescription .
theHist := aClassHistory .
theHist == nil
  ifTrue: [ theHist := ClassHistory new name: className ] .
theHist add: result .
result classHistory: theHist .
result timeStamp: DateTime now.
result userId: System myUserProfile userId.
result extraDict: SymbolDictionary new .

" if superclasses have class instance variables defined "
(selfClass := self class) instSize > (resultClass := result class) instSize
  ifTrue: [ 
    resultClass instSize + 1 to: selfClass instSize do: [ :i |
      resultClass addInstVarNames: #[ selfClass _instVarNames at: i ]
    ]
  ].
anArrayOfClassInstVars size > 0 ifTrue: [
  resultClass addInstVarNames: anArrayOfClassInstVars
].

modifyBoolean ifFalse:[ result immediateInvariant ] .

^ result
%

category: 'Subclass Creation'
method: Class
_validName: str

"Returns whether the given string contains Characters valid for a class name.
 The string need not be a Symbol."

| ch |

(str size == 0 _or: [str size > 64]) ifTrue: [
  ^false
].

ch := str at: 1.
(ch = $_ _or: [ch isLetter]) ifFalse: [
  ^false
].

2 to: str size do: [ :i |
  ch := str at: i.
  (ch = $_ _or: [ch isAlphaNumeric]) ifFalse: [
    ^false
  ].
].

^true.
%

category: 'Subclass Creation'
method: Class
byteSubclass: aString
classVars: anArrayOfClassVars
classInstVars: anArrayOfClassInstVars
poolDictionaries: anArrayOfPoolDicts
inDictionary: aDictionary
instancesInvariant: invarBoolean

"Creates and returns a new byte subclass of the receiver.  You are not
 permitted to modify the new class after it is created.  If the receiver is not
 some kind of String class, then instances of the new class store and return
 SmallIntegers in the range 0 - 255.

 If aString is the name of a Class that is visible to the current user, this
 method creates the new class as a new version of the existing class, and they
 then share the same class history.  However, if no class named aString is
 visible to the user, then the new class is no relation to any existing class,
 and it has a new class history.

 This method generates an error if instances of the receiver are of special
 storage format, if they are NSCs, or if they have instance variables."

self _validatePrivilege.
^self
  byteSubclass: aString
  classVars: anArrayOfClassVars
  classInstVars: anArrayOfClassInstVars
  poolDictionaries: anArrayOfPoolDicts
  inDictionary: aDictionary
  newVersionOf: (self _nilOrClassNamed: aString)
  description: nil
  isInvariant: invarBoolean
%

category: 'Backward Compatibility'
method: Class
byteSubclass: aString
classVars: anArrayOfClassVars
classInstVars: anArrayOfClassInstVars
poolDictionaries: anArrayOfPoolDicts
inDictionary: aDictionary
description: aDescription
isInvariant: invarBoolean

"Obsolete in GemStone 4.1.  The preferred methods are in the Subclass Creation
 category.  Look for the method that omits this method's keyword description:
 and changes its keyword isInvariant: to instancesInvariant:."

self _validatePrivilege.
^self
  byteSubclass: aString
  classVars: anArrayOfClassVars
  classInstVars: anArrayOfClassInstVars
  poolDictionaries: anArrayOfPoolDicts
  inDictionary: aDictionary
  newVersionOf: (self _nilOrClassNamed: aString)
  description: aDescription
  isInvariant: invarBoolean
%

category: 'Subclass Creation'
method: Class
byteSubclass: aString
classVars: anArrayOfClassVars
classInstVars: anArrayOfClassInstVars
poolDictionaries: anArrayOfPoolDicts
inDictionary: aDictionary
newVersionOf: oldClass
instancesInvariant: invarBoolean

"Creates and returns a new byte subclass of the receiver.  You are not
 permitted to modify the new class after it is created.  If the receiver is not
 some kind of String class, then instances of the new class store and return
 SmallIntegers in the range 0 - 255.

 If oldClass is visible to the current user, this method creates the new class
 as a new version of oldClass, and the two classes then share the same class
 history.  However, if oldClass is nil, then the new class is no relation
 to any existing class, and it has a new class history.

 This method generates an error if instances of the receiver are of special
 storage format, if they are NSCs, or if they have instance variables."

self _validatePrivilege.
^ self byteSubclass: aString
    classVars: anArrayOfClassVars
    classInstVars: anArrayOfClassInstVars
    poolDictionaries: anArrayOfPoolDicts
    inDictionary: aDictionary
    newVersionOf: oldClass
    description: nil
    isInvariant: invarBoolean
%

category: 'Backward Compatibility'
method: Class
byteSubclass: aString
classVars: anArrayOfClassVars
classInstVars: anArrayOfClassInstVars
poolDictionaries: anArrayOfPoolDicts
inDictionary: aDictionary
newVersionOf: oldClass
description: aDescription
isInvariant: invarBoolean

"Obsolete in GemStone 4.1.  The preferred methods are in the Subclass Creation
 category.  Look for the method that omits this method's keyword description:
 and changes its keyword isInvariant: to instancesInvariant:."

| hist theFormat |
self _validatePrivilege.
oldClass ~~ nil ifTrue:[  "fix bug 11833"
  oldClass _validateClass: Class .
  hist := oldClass classHistory .
  ].

(self subclassesDisallowed) ifTrue: [
  ^ self _error: #classErrSubclassDisallowed].
aDictionary _validateClass: SymbolDictionary.
(instVars ~~ 0) ifTrue: [^ self _error: #classErrByteObjInstVars].
((self instancesInvariant) & (invarBoolean not)) ifTrue: [
  ^ self _error: #classErrInvariantSuperClass
  ].
(self isNsc) ifTrue: [ ^ aString _error: #classErrBadFormat ].
theFormat := (format bitAnd: 16r3 bitInvert) bitOr: (16r1 + 16r4) . 
invarBoolean ifTrue:[ theFormat := theFormat bitOr: 16r8 ].

^ self _subclass: aString
         instVarNames:  #() 
         format: theFormat
         constraints:  #() 
         classVars: anArrayOfClassVars
         classInstVars: anArrayOfClassInstVars
         poolDictionaries: anArrayOfPoolDicts
         inDictionary: aDictionary
         inClassHistory: hist
         description: aDescription
         isModifiable: false
%

category: 'Backward Compatibility'
method: Class
indexableSubclass: aString
instVarNames: anArrayOfStrings
classVars: anArrayOfClassVars
classInstVars: anArrayOfClassInstVars
poolDictionaries: anArrayOfPoolDicts
inDictionary: aDictionary
constraints: aConstraint
instancesInvariant: invarBoolean
isModifiable: modifyBoolean

"Obsolete in 2.1.  The preferred methods are in the Subclass Creation
 category.  See the similar method without the constraints keyword."

"Creates and returns a new indexable subclass of the receiver.  Instances of the
 new class are represented as pointer objects.

 If aString is the name of a Class that is visible to the current user, this
 method creates the new class as a new version of the existing class, and they
 then share the same class history.  However, if no class named aString is
 visible to the user, then the new class is no relation to any existing class,
 and it has a new class history.

 This method generates an error if instances of the receiver are of special
 storage format or if they are NSCs."

self _validatePrivilege.
^self
  indexableSubclass: aString
  instVarNames: anArrayOfStrings
  classVars: anArrayOfClassVars
  classInstVars: anArrayOfClassInstVars
  poolDictionaries: anArrayOfPoolDicts
  inDictionary: aDictionary
  constraints: aConstraint
  instancesInvariant: invarBoolean
  newVersionOf: (self _nilOrClassNamed: aString)
  description: nil
  isModifiable: modifyBoolean
%

category: 'Subclass Creation'
method: Class
indexableSubclass: aString
instVarNames: anArrayOfStrings
classVars: anArrayOfClassVars
classInstVars: anArrayOfClassInstVars
poolDictionaries: anArrayOfPoolDicts
inDictionary: aDictionary
instancesInvariant: invarBoolean
isModifiable: modifyBoolean

"Creates and returns a new indexable subclass of the receiver.  Instances of the
 new class are represented as pointer objects.

 If aString is the name of a Class that is visible to the current user, this
 method creates the new class as a new version of the existing class, and they
 then share the same class history.  However, if no class named aString is
 visible to the user, then the new class is no relation to any existing class,
 and it has a new class history.

 This method generates an error if instances of the receiver are of special
 storage format or if they are NSCs."

self _validatePrivilege.
^self
  indexableSubclass: aString
  instVarNames: anArrayOfStrings
  classVars: anArrayOfClassVars
  classInstVars: anArrayOfClassInstVars
  poolDictionaries: anArrayOfPoolDicts
  inDictionary: aDictionary
  constraints: #()
  instancesInvariant: invarBoolean
  newVersionOf: (self _nilOrClassNamed: aString)
  description: nil
  isModifiable: modifyBoolean
%

category: 'Backward Compatibility'
method: Class
indexableSubclass: aString
instVarNames: anArrayOfStrings
classVars: anArrayOfClassVars
classInstVars: anArrayOfClassInstVars
poolDictionaries: anArrayOfPoolDicts
inDictionary: aDictionary
constraints: aConstraint
instancesInvariant: invarBoolean
description: aDescription
isModifiable: modifyBoolean

"Obsolete in GemStone 4.1.  The preferred methods are in the Subclass Creation
 category.  Look for the method that omits this method's keyword description:."

self _validatePrivilege.
^self
  indexableSubclass: aString
  instVarNames: anArrayOfStrings
  classVars: anArrayOfClassVars
  classInstVars: anArrayOfClassInstVars
  poolDictionaries: anArrayOfPoolDicts
  inDictionary: aDictionary
  constraints: aConstraint
  instancesInvariant: invarBoolean
  newVersionOf: (self _nilOrClassNamed: aString)
  description: aDescription
  isModifiable: modifyBoolean
%

category: 'Backward Compatibility'
method: Class
indexableSubclass: aString
instVarNames: anArrayOfStrings
classVars: anArrayOfClassVars
classInstVars: anArrayOfClassInstVars
poolDictionaries: anArrayOfPoolDicts
inDictionary: aDictionary
constraints: aConstraint
instancesInvariant: invarBoolean
newVersionOf: oldClass
isModifiable: modifyBoolean

"Obsolete in 2.1.  The preferred methods are in the Subclass Creation
 category.  See the similar method without the constraints keyword."

"Creates and returns a new indexable subclass of the receiver.  Instances of the
 new class are represented as pointer objects.

 If oldClass is visible to the current user, this method creates the new class
 as a new version of oldClass, and the two classes then share the same class
 history.  However, if oldClass is nil, then the new class is no relation
 to any existing class, and it has a new class history.

 This method generates an error if instances of the receiver are of special
 storage format or if they are NSCs."

self _validatePrivilege.
^ self indexableSubclass: aString
    instVarNames: anArrayOfStrings
    classVars: anArrayOfClassVars
    classInstVars: anArrayOfClassInstVars
    poolDictionaries: anArrayOfPoolDicts
    inDictionary: aDictionary
    constraints: aConstraint
    instancesInvariant: invarBoolean
    newVersionOf: oldClass
    description: nil
    isModifiable: modifyBoolean
%

category: 'Subclass Creation'
method: Class
indexableSubclass: aString
instVarNames: anArrayOfStrings
classVars: anArrayOfClassVars
classInstVars: anArrayOfClassInstVars
poolDictionaries: anArrayOfPoolDicts
inDictionary: aDictionary
instancesInvariant: invarBoolean
newVersionOf: oldClass
isModifiable: modifyBoolean

"Creates and returns a new indexable subclass of the receiver.  Instances of the
 new class are represented as pointer objects.

 If oldClass is visible to the current user, this method creates the new class
 as a new version of oldClass, and the two classes then share the same class
 history.  However, if oldClass is nil, then the new class is no relation
 to any existing class, and it has a new class history.

 This method generates an error if instances of the receiver are of special
 storage format or if they are NSCs."

self _validatePrivilege.
^ self indexableSubclass: aString
    instVarNames: anArrayOfStrings
    classVars: anArrayOfClassVars
    classInstVars: anArrayOfClassInstVars
    poolDictionaries: anArrayOfPoolDicts
    inDictionary: aDictionary
    constraints: #()
    instancesInvariant: invarBoolean
    newVersionOf: oldClass
    description: nil
    isModifiable: modifyBoolean
%

category: 'Backward Compatibility'
method: Class
indexableSubclass: aString
instVarNames: anArrayOfStrings
classVars: anArrayOfClassVars
classInstVars: anArrayOfClassInstVars
poolDictionaries: anArrayOfPoolDicts
inDictionary: aDictionary
constraints: aConstraint
instancesInvariant: invarBoolean
newVersionOf: oldClass
description: aDescription
isModifiable: modifyBoolean

"Obsolete in GemStone 4.1.  The preferred methods are in the Subclass Creation
 category.  Look for the method that omits this method's keyword description:."

| theFormat hist |

self _validatePrivilege.
oldClass ~~ nil ifTrue:[  "fix bug 11833"
  oldClass _validateClass: Class .
  hist := oldClass classHistory .
  ].

(self subclassesDisallowed) ifTrue: [
  ^ self _error: #classErrSubclassDisallowed].
aDictionary _validateClass:  SymbolDictionary .
((self instancesInvariant) & (invarBoolean not)) ifTrue: [
  ^ self _error: #classErrInvariantSuperClass
  ].
(aConstraint isKindOf: Array) ifFalse: [
  ^ aConstraint _error: #classErrConstraintNotClass 
  ].
anArrayOfStrings _validateClass: Array.
(self isNsc) ifTrue: [^ self _error: #classErrNscNotIndexable].
(self isBytes) ifTrue: [ ^ aString _error: #classErrBadFormat].

theFormat := format bitOr: 16r4 "add indexable bit" .
invarBoolean ifTrue:[ theFormat := theFormat bitOr: 16r8 ].

^ self _subclass: aString
        instVarNames: anArrayOfStrings
        format: theFormat
        constraints: aConstraint
        classVars: anArrayOfClassVars
        classInstVars: anArrayOfClassInstVars
        poolDictionaries: anArrayOfPoolDicts
        inDictionary: aDictionary
        inClassHistory: hist
        description: aDescription
        isModifiable: modifyBoolean
%

category: 'Backward Compatibility'
method: Class
subclass: aString
instVarNames: anArrayOfStrings
classVars: anArrayOfClassVars
classInstVars: anArrayOfClassInstVars
poolDictionaries: anArrayOfPoolDicts
inDictionary: aDictionary
constraints: aConstraint
instancesInvariant: invarBoolean
isModifiable: modifyBoolean

"Obsolete in 2.1  The perferred methods are in the category Subclass Creation;
 see the similar method without the constraints keyword."

"Creates and returns a new subclass of the receiver.

 If aString is the name of a Class that is visible to the current user, this
 method creates the new class as a new version of the existing class, and they
 then share the same class history.  However, if no class named aString is
 visible to the user, then the new class is no relation to any existing class,
 and it has a new class history."

self _validatePrivilege.
^self
  subclass: aString
  instVarNames: anArrayOfStrings
  classVars: anArrayOfClassVars
  classInstVars: anArrayOfClassInstVars
  poolDictionaries: anArrayOfPoolDicts
  inDictionary: aDictionary
  constraints: aConstraint
  instancesInvariant: invarBoolean
  newVersionOf: (self _nilOrClassNamed: aString)
  description: nil
  isModifiable: modifyBoolean
%

category: 'Subclass Creation'
method: Class
subclass: aString
instVarNames: anArrayOfStrings
classVars: anArrayOfClassVars
classInstVars: anArrayOfClassInstVars
poolDictionaries: anArrayOfPoolDicts
inDictionary: aDictionary
instancesInvariant: invarBoolean
isModifiable: modifyBoolean

"Creates and returns a new subclass of the receiver.

 If aString is the name of a Class that is visible to the current user, this
 method creates the new class as a new version of the existing class, and they
 then share the same class history.  However, if no class named aString is
 visible to the user, then the new class is no relation to any existing class,
 and it has a new class history."

self _validatePrivilege.
^self
  subclass: aString
  instVarNames: anArrayOfStrings
  classVars: anArrayOfClassVars
  classInstVars: anArrayOfClassInstVars
  poolDictionaries: anArrayOfPoolDicts
  inDictionary: aDictionary
  constraints: #()
  instancesInvariant: invarBoolean
  newVersionOf: (self _nilOrClassNamed: aString)
  description: nil
  isModifiable: modifyBoolean
%

category: 'Backward Compatibility'
method: Class
subclass: aString
instVarNames: anArrayOfStrings
classVars: anArrayOfClassVars
classInstVars: anArrayOfClassInstVars
poolDictionaries: anArrayOfPoolDicts
inDictionary: aDictionary
constraints: aConstraint
instancesInvariant: invarBoolean
description: aDescription
isModifiable: modifyBoolean

"Obsolete in GemStone 4.1.  The preferred methods are in the Subclass Creation
 category.  Look for the method that omits this method's keyword description:."

self _validatePrivilege.
^self
  subclass: aString
  instVarNames: anArrayOfStrings
  classVars: anArrayOfClassVars
  classInstVars: anArrayOfClassInstVars
  poolDictionaries: anArrayOfPoolDicts
  inDictionary: aDictionary
  constraints: aConstraint
  instancesInvariant: invarBoolean
  newVersionOf: (self _nilOrClassNamed: aString)
  description: aDescription
  isModifiable: modifyBoolean
%

category: 'Backward Compatibility'
method: Class
subclass: aString
instVarNames: anArrayOfStrings
classVars: anArrayOfClassVars
classInstVars: anArrayOfClassInstVars
poolDictionaries: anArrayOfPoolDicts
inDictionary: aDictionary
constraints: aConstraint
instancesInvariant: invarBoolean
newVersionOf: oldClass
isModifiable: modifyBoolean

"Obsolete in 2.1.  The preferred class creation methods are in the category
 Subclass Creation; see the similar method without the constraints keyword."

"Creates and returns a new subclass of the receiver.

 If oldClass is visible to the current user, this method creates the new class
 as a new version of oldClass, and the two classes then share the same class
 history.  However, if oldClass is nil, then the new class is no relation
 to any existing class, and it has a new class history."

self _validatePrivilege.
^ self subclass: aString
    instVarNames: anArrayOfStrings
    classVars: anArrayOfClassVars
    classInstVars: anArrayOfClassInstVars
    poolDictionaries: anArrayOfPoolDicts
    inDictionary: aDictionary
    constraints: aConstraint
    instancesInvariant: invarBoolean
    newVersionOf: oldClass
    description: nil
    isModifiable: modifyBoolean

%

category: 'Subclass Creation'
method: Class
subclass: aString
instVarNames: anArrayOfStrings
classVars: anArrayOfClassVars
classInstVars: anArrayOfClassInstVars
poolDictionaries: anArrayOfPoolDicts
inDictionary: aDictionary
instancesInvariant: invarBoolean
newVersionOf: oldClass
isModifiable: modifyBoolean

"Creates and returns a new subclass of the receiver.

 If oldClass is visible to the current user, this method creates the new class
 as a new version of oldClass, and the two classes then share the same class
 history.  However, if oldClass is nil, then the new class is no relation
 to any existing class, and it has a new class history."

self _validatePrivilege.
^ self subclass: aString
    instVarNames: anArrayOfStrings
    classVars: anArrayOfClassVars
    classInstVars: anArrayOfClassInstVars
    poolDictionaries: anArrayOfPoolDicts
    inDictionary: aDictionary
    constraints: #()
    instancesInvariant: invarBoolean
    newVersionOf: oldClass
    description: nil
    isModifiable: modifyBoolean
%

category: 'Backward Compatibility'
method: Class
subclass: aString
instVarNames: anArrayOfStrings
classVars: anArrayOfClassVars
classInstVars: anArrayOfClassInstVars
poolDictionaries: anArrayOfPoolDicts
inDictionary: aDictionary
constraints: aConstraint
instancesInvariant: invarBoolean
newVersionOf: oldClass
description: aDescription
isModifiable: modifyBoolean

"Obsolete in GemStone 4.1.  The preferred methods are in the Subclass Creation
 category.  Look for the method that omits this method's keyword description:."

| hist theConstraints theFormat |

self _validatePrivilege.
oldClass ~~ nil ifTrue:[  "fix bug 11833"
  oldClass _validateClass: Class .
  hist := oldClass classHistory .
  ].

(self subclassesDisallowed) ifTrue: [
  ^ self _error: #classErrSubclassDisallowed ].
aDictionary _validateClass:  SymbolDictionary .
((self instancesInvariant) & (invarBoolean not)) ifTrue: [
  ^ self _error: #classErrInvariantSuperClass].
anArrayOfStrings _validateClass: Array.

(self isNsc) ifTrue:[
    (aConstraint isKindOf: Array)
       ifTrue:[ theConstraints := aConstraint "same as for pointers" ]
       ifFalse:[ "for compatibility with 3.0, construct an Array"
                 "specifying inherited constraints on named instance variables"                 "plus the specified constraint on unnamed instance variables."
         theConstraints := #[ aConstraint ] .
         ].
     theFormat := format .
     invarBoolean ifTrue:[ theFormat := theFormat bitOr: 16r8 ].
     ].  "end NSC case"

(self isPointers) ifTrue: [
   (aConstraint isKindOf: Array) ifFalse: [
     ^ aConstraint _error: #classErrConstraintNotClass ].
   theConstraints := aConstraint .
   theFormat := format .
   invarBoolean ifTrue:[ theFormat := theFormat bitOr: 16r8 ].
   ].
(self isBytes) ifTrue:[
   (instVars ~~ 0) ifTrue: [^ self _error: #classErrByteObjInstVars].
   (anArrayOfStrings size ~~ 0) ifTrue: [
     ^ self _error: #classErrByteObjInstVars].
   (aConstraint isKindOf: Array) ifFalse: [
     ^ aConstraint _error: #classErrConstraintNotClass ].
   (aConstraint size ~~ 0) ifTrue: [ ^ self _error: #classErrBadConstraint ] .
   theConstraints := aConstraint .
   theFormat := format .
   invarBoolean ifTrue:[ theFormat := theFormat bitOr: 16r8 ].
   ].
^ self _subclass: aString
          instVarNames: anArrayOfStrings
          format: theFormat
          constraints: theConstraints
          classVars: anArrayOfClassVars
          classInstVars: anArrayOfClassInstVars
          poolDictionaries: anArrayOfPoolDicts
          inDictionary: aDictionary
          inClassHistory: hist
          description: aDescription
          isModifiable: modifyBoolean

%

! fixed 32132
category: 'Updating'
method: Class
classHistory: aClassHistory

"Set the class history of the receiver. Returns the receiver."

self _validatePrivilege.
aClassHistory ~~ nil ifTrue:[ aClassHistory _validateInstanceOf: ClassHistory].
self validateIsVariant .
classHistory := aClassHistory .
self _refreshClassCache .
%


category: 'Updating'
method: Class
addNewVersion: aClass

"Make aClass a new version of the receiver.  That is, add aClass to the
 receiver's history, and set aClass's history to be the same as the
 receiver's history.  The existing history of aClass will have aClass
 removed from it."

self _validatePrivilege.
aClass classHistory removeVersion: aClass.
aClass _beVariantWhile:
  [aClass classHistory: classHistory].
classHistory newVersion: aClass
%

category: 'Updating'
method: Class
description: aDescription

"Update the description of this Class.  Returns the argument."

^ description := aDescription
%

category: 'Updating'
method: Class
migrationDestination: aClass

"Update the migrationDestination instance variable.  Returns the argument."

self _validatePrivilege.
aClass ~~ nil ifTrue:[ aClass _validateClass: Class ].
migrationDestination := aClass .
self _refreshClassCache .
^ aClass
%

category: 'Updating'
method: Class
timeStamp: aDateTime

"Set the value of the timeStamp instance variable.
 For use only when creating a class, while the class is not yet invariant."

self _validatePrivilege.
self validateIsVariant .
aDateTime ~~ nil ifTrue:[ aDateTime _validateClass: DateTime ].
timeStamp := aDateTime
%

category: 'Updating'
method: Class
userId: aString

"Set the value of the userId instance variable.
 For use only when creating a class, while the class is not yet invariant."

self _validatePrivilege.
self validateIsVariant .
aString ~~ nil ifTrue:[ aString _validateClass: CharacterCollection ].
userId := aString
%

category: 'Updating'
method: Class
extraDict: aSymbolDictionary

"Set the value of the extraDict instance variable."

self _validatePrivilege.
aSymbolDictionary ~~ nil ifTrue:[ aSymbolDictionary _validateClass: SymbolDictionary].
extraDict := aSymbolDictionary
%

category: 'Updating Variables'
method: Class
addClassVarName: aString

"Add aString to the class variable list for the receiver, if the
 class variable is not already defined."

| aSym definingClass |

self _validatePrivilege.
aSym := aString asSymbol .
aSym validateIsIdentifier .
definingClass := self _classDefiningClassVar: aSym .  "fix bug 10480"
definingClass ~~ nil ifTrue:[
  definingClass == self ifTrue:[ 
    "if the receiver already defines the class variable, 
       do nothing and return silently    (fix bug 8094) "
    ^ self  
    ].
  definingClass _error: #classErrClassVarNameExists args: #[ aSym ] .
  self _uncontinuableError .
  ].
classVars at: aSym put: nil .
%

category: 'Updating Variables'
method: Class
addSharedPool: aDictionary

"Add aDictionary to the end of the shared pool list for the receiver.

 You may use this method only if, when the receiver was created, the argument
 to poolDictionaries: was an Array (rather than a literal Array, which would
 create an InvariantArray).  See Class | subclass:."

self _validatePrivilege.
aDictionary _validateClass:  SymbolDictionary .
(poolDictionaries includesIdentical: aDictionary) "already in shared pool"
   ifTrue: [ ^ self _error: #classErrPoolDictExists args: #[aDictionary]].
poolDictionaries add: aDictionary
%

category: 'Updating Variables'
method: Class
removeClassVarName: aString

"Remove aString from the class variable list for the receiver.  Generates an
 error if aString is not specified as a class variable in the receiver."

| aSym |

self _validatePrivilege.
aSym := aString asSymbol .
(classVars includesKey: aSym)
ifTrue:
   [classVars removeKey: aSym ]
ifFalse:
   [^ self _error: #classErrClassVarNotFound args: #[aString]]
%

category: 'Updating Variables'
method: Class
removeSharedPool: aDictionary

"Remove aDictionary from the shared pool list for the receiver.  Generates an
 error if aDictionary is not a shared pool for the receiver.

 You may use this method only if, when the receiver was created, the argument
 to poolDictionaries: was an Array rather than a literal Array, which would
 create an InvariantArray.  (See Class | subclass:.)"

| index "loop index" |

self _validatePrivilege.
(poolDictionaries includesIdentical: aDictionary)
   ifTrue: [index := 1.  "find aDictionary in the pool"
            [aDictionary == (poolDictionaries at: index)]
               whileFalse: [index := index + 1].
            poolDictionaries deleteObjectAt: index]
   ifFalse: [ ^ self _error: #classErrPoolDictNotFound args: #[aDictionary]]
            "aDictionary not found in shared pool"
%

category: 'Versions'
method: Class
isVersionOf: anotherClass

"Returns whether the receiver and the given class share the same class
 history."

^anotherClass classHistory == classHistory _and: [classHistory ~~ nil]
%

category: 'Private'
method: Class
_subclass: aString
instVarNames: anArrayOfStrings
format: anInteger
constraints: aConstraint
classVars: aSymbolDictionary
poolDictionaries: anArrayOfPoolDicts

""

"Gemstone64, this primitive enforces the restriction that
 a class cannot be more than 450 classes below Object when
 following the superClass chain upwards ."

<primitive: 233>
aString _validateClass: Symbol.
anInteger _validateClass: SmallInteger.
anArrayOfStrings _validateClass: Array.
((self == IdentityBag) _or: [self inheritsFrom: IdentityBag])
   ifTrue: [(aConstraint isKindOf: Class)
      ifFalse: [ ^ aConstraint _error: #classErrConstraintNotClass]]
   ifFalse: [(aConstraint isKindOf: Array)
      ifFalse: [ ^ aConstraint _error: #classErrConstraintNotClass]].
aSymbolDictionary _validateClass: SymbolDictionary.
anArrayOfPoolDicts _validateClass: Array.

^ self _primitiveFailed:
   #_subclass:instVarNames:format:constraints:classVars:poolDictionaries:
%

! remove code that was commented out

category: 'Backward Compatibility'
method: Class
byteSubclass: aString
classVars: anArrayOfClassVars
poolDictionaries: anArrayOfPoolDicts
inDictionary: aDictionary
isInvariant: invarBoolean

"Obsolete in GemStone 4.0.  The preferred methods are in the Subclass Creation
 category."

self _validatePrivilege.
^ self byteSubclass: aString
    classVars: anArrayOfClassVars
    classInstVars: nil
    poolDictionaries: anArrayOfPoolDicts
    inDictionary: aDictionary
    instancesInvariant: invarBoolean
%

category: 'Backward Compatibility'
method: Class
byteSubclass: aString
classVars: anArrayOfClassVars
poolDictionaries: anArrayOfPoolDicts
inDictionary: aDictionary
inClassHistory: aClassHistory
description: aDescription
isInvariant: invarBoolean

"Obsolete in GemStone 4.0.  The preferred methods are in the Subclass Creation
 category."

self _validatePrivilege.
^self byteSubclass: aString
  classVars: anArrayOfClassVars
  classInstVars: nil
  poolDictionaries: anArrayOfPoolDicts
  inDictionary: aDictionary
  inClassHistory: aClassHistory
  description: aDescription
  isInvariant: invarBoolean
%

category: 'Backward Compatibility'
method: Class
byteSubclass: aString
classVars: anArrayOfClassVars
classInstVars: anArrayOfClassInstVars
poolDictionaries: anArrayOfPoolDicts
inDictionary: aDictionary
inClassHistory: aClassHistory
description: aDescription
isInvariant: invarBoolean

"Obsolete in GemStone 4.0.  The preferred methods are in the Subclass Creation
 category."

| theFormat |

self _validatePrivilege.
(self subclassesDisallowed) ifTrue: [
  ^ self _error: #classErrSubclassDisallowed].
aDictionary _validateClass: SymbolDictionary.
(instVars ~~ 0) ifTrue: [^ self _error: #classErrByteObjInstVars].
((self instancesInvariant) & (invarBoolean not)) ifTrue: [
  ^ self _error: #classErrInvariantSuperClass].
(self isNsc) ifTrue: [ ^ aString _error: #classErrBadFormat ].
theFormat := (format bitAnd: 16r3 bitInvert) bitOr: (16r1 + 16r4)  . 
invarBoolean ifTrue:[ theFormat := theFormat bitOr: 16r8 ].

^ self _subclass: aString
         instVarNames:  #() 
         format: theFormat
         constraints:  #() 
         classVars: anArrayOfClassVars
         classInstVars: anArrayOfClassInstVars
         poolDictionaries: anArrayOfPoolDicts
         inDictionary: aDictionary
         inClassHistory: aClassHistory
         description: aDescription
         isModifiable: false
%

category: 'Backward Compatibility'
method: Class
indexableSubclass: aString
instVarNames: anArrayOfStrings
classVars: anArrayOfClassVars
poolDictionaries: anArrayOfPoolDicts
inDictionary: aDictionary
constraints: aConstraint
isInvariant: invarBoolean

"Obsolete in GemStone 4.0.  The preferred methods are in the Subclass Creation
 category."

self _validatePrivilege.
^ self indexableSubclass: aString
     instVarNames: anArrayOfStrings
     classVars: anArrayOfClassVars
     classInstVars: nil
     poolDictionaries: anArrayOfPoolDicts
     inDictionary: aDictionary
     constraints: aConstraint
     instancesInvariant: invarBoolean
     isModifiable: false
%

category: 'Backward Compatibility'
method: Class
indexableSubclass: aString
instVarNames: anArrayOfStrings
classVars: anArrayOfClassVars
poolDictionaries: anArrayOfPoolDicts
inDictionary: aDictionary
constraints: aConstraint
instancesInvariant: invarBoolean
isModifiable: modifyBoolean

"Obsolete in GemStone 4.0.  The preferred methods are in the Subclass Creation
 category."

self _validatePrivilege.
^ self indexableSubclass: aString
    instVarNames: anArrayOfStrings
    classVars: anArrayOfClassVars
    classInstVars: nil
    poolDictionaries: anArrayOfPoolDicts
    inDictionary: aDictionary
    constraints: aConstraint
    instancesInvariant: invarBoolean
    isModifiable: modifyBoolean
%

category: 'Backward Compatibility'
method: Class
indexableSubclass: aString
instVarNames: anArrayOfStrings
classVars: anArrayOfClassVars
poolDictionaries: anArrayOfPoolDicts
inDictionary: aDictionary
constraints: aConstraint
instancesInvariant: invarBoolean
inClassHistory: aClassHistory
description: aDescription
isModifiable: modifyBoolean

"Obsolete in GemStone 4.0.  The preferred methods are in the Subclass Creation
 category."

self _validatePrivilege.
^self indexableSubclass: aString
  instVarNames: anArrayOfStrings
  classVars: anArrayOfClassVars
  classInstVars: nil
  poolDictionaries: anArrayOfPoolDicts
  inDictionary: aDictionary
  constraints: aConstraint
  instancesInvariant: invarBoolean
  inClassHistory: aClassHistory
  description: aDescription
  isModifiable: modifyBoolean
%

category: 'Backward Compatibility'
method: Class
indexableSubclass: aString
instVarNames: anArrayOfStrings
classVars: anArrayOfClassVars
classInstVars: anArrayOfClassInstVars
poolDictionaries: anArrayOfPoolDicts
inDictionary: aDictionary
constraints: aConstraint
instancesInvariant: invarBoolean
inClassHistory: aClassHistory
description: aDescription
isModifiable: modifyBoolean

"Obsolete in GemStone 4.0.  The preferred methods are in the Subclass Creation
 category."

| theFormat |

self _validatePrivilege.
(self subclassesDisallowed) ifTrue: [
  ^ self _error: #classErrSubclassDisallowed].
aDictionary _validateClass: SymbolDictionary.
((self instancesInvariant) & (invarBoolean not)) ifTrue: [
  ^ self _error: #classErrInvariantSuperClass].
(aConstraint isKindOf: Array) ifFalse: [
  ^ aConstraint _error: #classErrConstraintNotClass ].
anArrayOfStrings _validateClass: Array.
(self isNsc) ifTrue: [^ self _error: #classErrNscNotIndexable].
(self isBytes) ifTrue: [ ^ aString _error: #classErrBadFormat].

theFormat := format bitOr: 16r4 "add indexable bit" .
invarBoolean ifTrue:[ theFormat := theFormat bitOr: 16r8 ].

^ self _subclass: aString
        instVarNames: anArrayOfStrings
        format: theFormat
        constraints: aConstraint
        classVars: anArrayOfClassVars
        classInstVars: anArrayOfClassInstVars
        poolDictionaries: anArrayOfPoolDicts
        inDictionary: aDictionary
        inClassHistory: aClassHistory
        description: aDescription
        isModifiable: modifyBoolean
%

category: 'Subclass Creation'
method: Class
subclass: aString
instVarNames: anArrayOfStrings
inDictionary: aDictionary

"Creates and returns a new subclass of the receiver.

 This method is a shortcut for convenience only.  It may not be retained in
 future GemStone releases.  Use it interactively or pedagogically, but avoid
 it in production code.

 The new class has no class variables, no class instance variables, no pool
 dictionaries, and no constraints beyond those inherited from the receiver.
 Instances of the new class are variant, but the new class itself is not
 modifiable.

 If aString is the name of a Class that is visible to the current user, this
 method creates the new class as a new version of the existing class, and they
 then share the same class history.  However, if no class named aString is
 visible to the user, then the new class is no relation to any existing class,
 and it has a new class history."

self _validatePrivilege.
^self
  subclass: aString
  instVarNames: anArrayOfStrings
  classVars:  #() 
  classInstVars:  #() 
  poolDictionaries: #[ ] 
  inDictionary: aDictionary
  constraints:  #() 
  instancesInvariant: false
  description: nil
  isModifiable: false
%

category: 'Backward Compatibility'
method: Class
subclass: aString
inDictionary: aDictionary
constraints: constraintSpec

"Obsolete in GemStone 4.0.  The preferred methods are in the Subclass Creation
 category."

self _validatePrivilege.
^ self subclass: aString
    instVarNames: #[]
    classVars:  #() 
    classInstVars:  #() 
    poolDictionaries: #[]
    inDictionary: aDictionary
    constraints: constraintSpec
    instancesInvariant: false
    isModifiable: false
%

category: 'Subclass Creation'
method: Class
subclass: aString
instVarNames: anArrayOfStrings
inDictionary: aDictionary
constraints: constraintSpec

"Creates and returns a new subclass of the receiver.

 This method is a shortcut for convenience only.  It may not be retained in
 future GemStone releases.  Use it interactively or pedagogically, but avoid
 it in production code.

 The new class has no class variables, no class instance variables, and no pool
 dictionaries.  Instances of the new class are variant, but the new class
 itself is not modifiable.

 If aString is the name of a Class that is visible to the current user, this
 method creates the new class as a new version of the existing class, and they
 then share the same class history.  However, if no class named aString is
 visible to the user, then the new class is no relation to any existing class,
 and it has a new class history."

self _validatePrivilege.
^self
  subclass: aString
  instVarNames: anArrayOfStrings
  classVars:  #() 
  poolDictionaries: #[]
  inDictionary: aDictionary
  constraints: constraintSpec
  instancesInvariant: false
  isModifiable: false
%

category: 'Backward Compatibility'
method: Class
subclass: aString
instVarNames: anArrayOfStrings
inDictionary: aDictionary
isModifiable: modifyBoolean

"Obsolete in GemStone 4.0.  The preferred methods are in the Subclass Creation
 category."

self _validatePrivilege.
^self
  subclass: aString
  instVarNames: anArrayOfStrings
  classVars:  #() 
  classInstVars:  #() 
  poolDictionaries: #[ ] 
  inDictionary: aDictionary
  constraints:  #() 
  instancesInvariant: false
  isModifiable: modifyBoolean
%

! fix bug 8684

category: 'Backward Compatibility'
method: Class
subclass: aString
instVarNames: anArrayOfStrings
classInstVars: anArrayOfClassInstVars
inDictionary: aDictionary
isModifiable: modifyBoolean

"Obsolete in GemStone 4.0.  The preferred methods are in the Subclass Creation
 category."

self _validatePrivilege.
^ self
    subclass: aString
    instVarNames: anArrayOfStrings
    classVars:  #() 
    classInstVars: anArrayOfClassInstVars
    poolDictionaries: #[ ] 
    inDictionary: aDictionary
    constraints:  #() 
    instancesInvariant: false
    isModifiable: modifyBoolean
%

category: 'Backward Compatibility'
method: Class
subclass: aString
instVarNames: anArrayOfStrings
classVars: anArrayOfClassVars
poolDictionaries: anArrayOfPoolDicts
inDictionary: aDictionary
constraints: aConstraint
isInvariant: invarBoolean

"Obsolete in GemStone 4.0.  The preferred methods are in the Subclass Creation
 category."

self _validatePrivilege.
^self
  subclass: aString
  instVarNames: anArrayOfStrings
  classVars: anArrayOfClassVars
  classInstVars: nil
  poolDictionaries: anArrayOfPoolDicts
  inDictionary: aDictionary
  constraints: aConstraint
  instancesInvariant: invarBoolean
  isModifiable: false
%

category: 'Backward Compatibility'
method: Class
subclass: aString
instVarNames: anArrayOfStrings
classVars: anArrayOfClassVars
poolDictionaries: anArrayOfPoolDicts
inDictionary: aDictionary
constraints: aConstraint
instancesInvariant: invarBoolean
isModifiable: modifyBoolean

"Obsolete in GemStone 4.0.  The preferred methods are in the Subclass Creation
 category."

self _validatePrivilege.
^self
   subclass: aString
   instVarNames: anArrayOfStrings
   classVars: anArrayOfClassVars
   classInstVars: nil
   poolDictionaries: anArrayOfPoolDicts
   inDictionary: aDictionary
   constraints: aConstraint
   instancesInvariant: invarBoolean
   isModifiable: modifyBoolean
%

category: 'Backward Compatibility'
method: Class
subclass: aString
instVarNames: anArrayOfStrings
classVars: anArrayOfClassVars
poolDictionaries: anArrayOfPoolDicts
inDictionary: aDictionary
constraints: aConstraint
instancesInvariant: invarBoolean
inClassHistory: aClassHistory
description: aDescription
isModifiable: modifyBoolean

"Obsolete in GemStone 4.0.  The preferred methods are in the Subclass Creation
 category."

self _validatePrivilege.
^self subclass: aString
  instVarNames: anArrayOfStrings
  classVars: anArrayOfClassVars
  classInstVars: nil
  poolDictionaries: anArrayOfPoolDicts
  inDictionary: aDictionary
  constraints: aConstraint
  instancesInvariant: invarBoolean
  inClassHistory: aClassHistory
  description: aDescription
  isModifiable: modifyBoolean
%

category: 'Backward Compatibility'
method: Class
subclass: aString
instVarNames: anArrayOfStrings
classVars: anArrayOfClassVars
classInstVars: anArrayOfClassInstVars
poolDictionaries: anArrayOfPoolDicts
inDictionary: aDictionary
constraints: aConstraint
instancesInvariant: invarBoolean
inClassHistory: aClassHistory
description: aDescription
isModifiable: modifyBoolean

"Obsolete in GemStone 4.0.  The preferred methods are in the Subclass Creation
 category."

| theConstraints theFormat |

self _validatePrivilege.
(self subclassesDisallowed) ifTrue: [
  ^ self _error: #classErrSubclassDisallowed ].
aDictionary _validateClass: SymbolDictionary.
((self instancesInvariant) & (invarBoolean not)) ifTrue: [
  ^ self _error: #classErrInvariantSuperClass].
anArrayOfStrings _validateClass: Array.

(self isNsc) ifTrue:[
    (aConstraint isKindOf: Array)
       ifTrue:[ theConstraints := aConstraint "same as for pointers" ]
       ifFalse:[ "for compatibility with 3.0, construct an Array"
                 "specifying inherited constraints on named instance variables"                 "plus the specified constraint on unnamed instance variables."
         theConstraints := #[ aConstraint ] .
         ].
     theFormat := format .
     invarBoolean ifTrue:[ theFormat := theFormat bitOr: 16r8 ].
     ].  "end NSC case"

(self isPointers) ifTrue: [
   (aConstraint isKindOf: Array) ifFalse: [
     ^ aConstraint _error: #classErrConstraintNotClass ].
   theConstraints := aConstraint .
   theFormat := format .
   invarBoolean ifTrue:[ theFormat := theFormat bitOr: 16r8 ].
   ].
(self isBytes) ifTrue:[
   (instVars ~~ 0) ifTrue: [^ self _error: #classErrByteObjInstVars].
   (anArrayOfStrings size ~~ 0) ifTrue: [
     ^ self _error: #classErrByteObjInstVars].
   (aConstraint isKindOf: Array) ifFalse: [
     ^ aConstraint _error: #classErrConstraintNotClass ].
   (aConstraint size ~~ 0) ifTrue: [ ^ self _error: #classErrBadConstraint ] .
   theConstraints := aConstraint .
   theFormat := format .
   invarBoolean ifTrue:[ theFormat := theFormat bitOr: 16r8 ].
   ].
^ self _subclass: aString
          instVarNames: anArrayOfStrings
          format: theFormat
          constraints: theConstraints
          classVars: anArrayOfClassVars
          classInstVars: anArrayOfClassInstVars
          poolDictionaries: anArrayOfPoolDicts
          inDictionary: aDictionary
          inClassHistory: aClassHistory
          description: aDescription
          isModifiable: modifyBoolean
%

category: 'Backward Compatibility'
method: Class
_decompileMethods: selectorsToDecompile
classRefExpression: refString
stripWith: stripSelector
includeAll: includeAll

"Obsolete in GemStone 5.0."

self _validatePrivilege.
^ self decompileMethods: selectorsToDecompile
        classRefExpression: refString
        stripWith: stripSelector
        includeAll: includeAll
%

category: 'Decompiling without Sources'
method: Class
decompileMethods: selectorsToDecompile
classRefExpression: refString
stripWith: stripSelector
includeAll: includeAll

"Returns a String that contains topaz commands to regenerate methods
 for the receiver.

 If selectorsToDecompile is nil, all methods will be decompiled, otherwise
 selectorsToDecompile should be a Collection of Symbols and only those methods
 listed in selectorsToDecompile will be included.

 If includeAll is true, all methods not decompiled will be filed out in
 source form and included in the result.

 stripSelector should be the selector of an instance method in GsMethod
 to be used in stripping the source strings.
 Examples are #emptySource , #sourceToFirstComment, #fullSource  .

 refString is a String containing an expression which evaluates to the
 class.  If refString is nil, the name of the receiver is used."

| result className LF methodCmd cls isMeta decompileDict
  classRefExpression |
self _validatePrivilege.
result := String new .
className := self name .
refString == nil ifTrue:[ classRefExpression := className ]
               ifFalse:[ classRefExpression := refString ] .
LF := Character lf .
selectorsToDecompile ~~ nil ifTrue:[
  decompileDict := SymbolKeyValueDictionary new .
  selectorsToDecompile do:[ :aSel | decompileDict at: aSel asSymbol put: nil ] .
  ].

includeAll ifTrue:[
  result addAll: 'removeallmethods ' ; addAll: className ; add: LF .
  result addAll: 'removeallclassmethods ' ; addAll: className ; add: LF .
  ].

2 timesRepeat: [
  cls == nil
    ifTrue:[
      cls := self .
      methodCmd := 'method: ' , className .  methodCmd add: LF .
      isMeta := false .
      ]
    ifFalse:[
      cls := self class .
      methodCmd := 'classmethod: ' , className .  methodCmd add: LF .
      isMeta := true .
      ].

  cls _categories associationsDo: [:categAssoc| | categCmd categName |
    categName := categAssoc key .
    categCmd := String withAll: 'category: ' .
    categCmd addAll: categName asString _asSource ; add: LF .

    categAssoc value do: [:aSelector |
      (decompileDict == nil _or:[ decompileDict includesKey: aSelector] )
        ifTrue:[
          "render in decompiled form"
          result addAll:
           ( (cls compiledMethodAt: aSelector)
               _decompileForCategory: categName classRef: classRefExpression
                 stripWith: stripSelector classMethod: isMeta ) .
          ]
        ifFalse:[
          includeAll ifTrue:[
            "render in source form"
            result addAll: categCmd ; addAll: methodCmd ;
              addAll: (cls sourceCodeAt: aSelector) ; addAll: LF ;
              addAll: $% ; addAll: LF .
            ].
          ].
      ].
    ].
  ].
" refresh method lookup caches "
result addAll: 'run' ; add: LF ;
  addAll: className  ; addAll: ' _refreshClassCache .' ; add: LF ;
  addAll: className  ; addAll: ' class _refreshClassCache .' ; add: LF ;
  addAll: ' ^ true' ; add: LF ;
  add: $% ; add: LF .

^ result
%

! _hasUncompiledMethods deleted

category: 'Accessing'
method: Class
extraDict

"Returns the SymbolDictionary held in extraDict that holds miscellaneous
 information about the receiver."

^extraDict
%

category: 'Accessing'
method: Class
_classInstVars

"Returns an Array of the receiver's class instance variables."

| civs |

civs := self class allInstVarNames.
civs removeFrom: 1 to: (self class superClass instSize).
^civs
%

! deleted :  Class >> convertTo5

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

^ ((format bitAnd: 16r800) == 0) not
%

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

  "Return true if the class format has the DbTransient bit set.
   See also  makeInstancesDbTransient ."

^ ((format bitAnd: 16r1000) == 0) not
%

category: 'Modifying Classes'
method: Class
makeInstancesNonPersistent

  "Takes effect immediately and will prevent committing new instances
   of the receiver in the current transaction.

   To change a non-modifiable class from persistent to non-persistent , 
   see  ClassOrganizer >> makeInstancesNonPersistent: . "

<primitive: 901>   "enter protected mode"
self validateIsModifiable .
self _makeInstancesNonPersistent .
System _disableProtectedMode.
%

category: 'Private'
method: Class
_makeInstancesNonPersistent

<protected>
self _validatePrivilege.
format := format bitOr: 16r800 .
self _refreshClassCache .
%

category: 'Modifying Classes'
method: Class
makeInstancesDbTransient

  "Takes effect immediately and will cause any instances that get
   committed to be DbTransient. 

   For a DbTransient object, instVars on disk are always nil.   
   The first transaction which causes the object to be reachable
   from committed state will commit the object with all instVars on
   disk set to nil .  Thereafter any stores to instVars of the committed 
   object in any session do not cause the object to be written 
   by the transaction.   

   Clustering a committed DbTransient object will
   cause the object to be rewritten to disk with all instVars nil
   when the transaction commits.  So clustering is the only way
   that concurrency conflict could occur involving a DbTransient object.

   The format of the receiver must be    non-indexable, pointer 
   otherwise an error is generated.

   You cannot change a non-modifiable class to or from dbTransient ."

<primitive: 901>   "enter protected mode"
self validateIsModifiable .
self _makeInstancesDbTransient: true .
System _disableProtectedMode.
%

category: 'Modifying Classes'
method: Class
makeInstancesNotDbTransient

  "Takes effect immediately and cancels any previous makeInstancesDbTransient.

   The receiver must be a modifiable class."

<primitive: 901>   "enter protected mode"
self validateIsModifiable .
self _makeInstancesDbTransient: false .
System _disableProtectedMode.
%

method: Class
_makeInstancesDbTransient: aBool

<protected>
self _validatePrivilege.
aBool ifTrue:[
  (self isPointers _and:[ self isIndexable not]) ifFalse:[
    self error:'Only non-indexable pointer objects may be DbTransient'.
  ].
  format := format bitOr: 16r1000 .
] ifFalse:[
  format := format bitAnd: (16r1000 bitInvert) 
].
self _refreshClassCache .
%

category: 'Modifying Classes'
method: Class
makeInstancesPersistent

  "Takes effect immediately.  
   To change a non-modifiable class from non-persistent to persistent, 
   see  ClassOrganizer >> makeInstancesPersistent: . "

<primitive: 901>   "enter protected mode"
self validateIsModifiable .
self _makeInstancesPersistent.
System _disableProtectedMode.
%

category: 'Private'
method: Class
_makeInstancesPersistent

<protected>
self _validatePrivilege.
self _validateInstancesPersistent .
superClass instancesNonPersistent ifTrue:[
  ^ self _error: #rtErrSuperclassIsNP .
].
format := (format bitOr: 16r800 ) bitXor: 16r800 .
self _refreshClassCache .
%

! final implementation of _validateInstancesPersistent is in class2.gs
!  this implementation is used during filein only
category: 'Private'
method: Class
_validateInstancesPersistent

"check that it is legal to make instances of the receiver 
 persistent."

^ self
%

category: 'Authorization'
method: Class
changeToSegment: seg

"Assigns the receiver and its non-shared components to the given segment.  The
 segments of class variable values are not changed.  The current user must have
 write access to both the old and new segments for this method to succeed."

  | anArray myClass classMethDict classCategories |

  self lockableParts do: [:each |
    each assignToSegment: seg
  ].

  myClass := self _class.
  classMethDict := myClass _methodDict.
  classCategories := myClass _categories.

  anArray := Array new.
  anArray add: methodDict; addAll: (methodDict values);
        add: classMethDict; addAll: (classMethDict values);
        add: categories; addAll: (categories values);
        add: classCategories; addAll: (classCategories values);
        add: poolDictionaries; add: (myClass _poolDictionaries);
        add: classHistory.

  (constraints isKindOf: Array) ifTrue: [
    anArray add: constraints
    ].

  (anArray asIdentitySet) do: [ :anObj |
    ((anObj isSpecial) _or: [ anObj _isSymbol ])
      ifFalse: [ anObj assignToSegment: seg ]
    ].
%

