!=========================================================================
! Copyright (C) VMware, Inc. 1986-2011.  All Rights Reserved.
!
! $Id: metacla.gs,v 1.9 2008-01-09 22:50:12 stever Exp $
!
! Superclass Hierarchy:
!   Metaclass, Behavior, Object.
!
!=========================================================================

removeallmethods Metaclass
removeallclassmethods Metaclass

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

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

txt := (GsDocText new) details:
'Each Metaclass describes the protocol of its single instance, which is a
 Class.  The class methods of GemStone kernel classes are actually stored as
 instance methods of those classes'' Metaclasses.

 For example, 3 is an instance of the class SmallInteger.  SmallInteger is
 an instance of the Metaclass SmallInteger class, and describes the protocol
 of all SmallIntegers.  SmallInteger class is itself an instance of
 Metaclass, and describes the protocol (that is, the class methods) of the class
 SmallInteger.

 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 class SmallInteger).
 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).'.
doc documentClassWith: txt.

txt := (GsDocText new) details:
'The Class that this instance of Metaclass describes.'.
doc documentInstVar: #thisClass with: txt.

self description: doc.
%

category: 'Accessing'
method: Metaclass
name

"Returns the name of the receiver.  For example, SmallInteger class
 name returns SmallInteger class (the receiver, a Metaclass)."

(thisClass == nil)
  ifTrue:[^'aMetaclass']
  ifFalse:[^thisClass name , ' class']
%

category: 'Accessing'
method: Metaclass
thisClass

"Returns the Class of which the receiver is a Metaclass.  For example,
 SmallInteger class thisClass returns SmallInteger (the Class)."

^ thisClass
%

category: 'Accessing'
method: Metaclass
classHistory

"Returns the classHistory for the Class of which the receiver is a Metaclass."

^ thisClass classHistory
%

category: 'Instance Creation'
method: Metaclass
new

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

self shouldNotImplement: #new
%

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

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

self shouldNotImplement: #new:
%

category: 'Clustering'
method: Metaclass
clusterDescription

"Overrides the inherited method.  For instances of Metaclass, only the
 classVars and categories instance variables are clustered.  (The instance
 variables instVarNames and constraints are not clustered since they are shared
 among all Metaclasses.)"

self cluster
  ifTrue: [ ^ true ]
  ifFalse:
    [ classVars clusterDepthFirst.
      categories rebuildIfNeeded.
      categories clusterDepthFirst.
      ^ false
    ].
%

category: 'Clustering'
method: Metaclass
clusterDepthFirst

"Overrides the inherited method.  This method clusters, in depth-first order,
 the receiver's classVars, methodDict, and categories instance variables.
 (This method does not cluster the instance variables superclass, which may be
 shared with other Metaclasses; instVarNames and constraints, which are shared
 among all Metaclasses; and pool dictionaries, which are shared among an
 arbitrary number of Behaviors.)  The receiver itself is not clustered.

 Returns true if the receiver has already been clustered during the current
 transaction; returns false otherwise."

self cluster
  ifTrue:
    [ ^ true ]
  ifFalse:
    [ classVars cluster.
      methodDict clusterDepthFirst.
      categories clusterDepthFirst.
      ^ false
    ].
%

category: 'Class Instance Variables'
method: Metaclass
addInstVarNames: instVarNamesArray

"Adds the instance variables specified in the argument to the receiver and any
 of its subclasses.  Generates an error upon encountering a name that is not a
 valid instance variable name or that is already an instance variable of the
 receiver.

 Instance variables that are added to a Metaclass are called
 Class Instance Variables."

| ivnames oldEnd |

(thisClass isInvariant not _or: [thisClass subclassesDisallowed]) ifFalse: [
  ^ self _error: #rtErrClassNotModifiable
  ].
instVarNamesArray size == 0 ifTrue: [ ^self ].
"allow an error handler to proceed from the errors signaled by the validation
 method and thus skip offending instance variable names"
ivnames := Array new.
instVarNamesArray do:[ :aStr | ivnames add: aStr asSymbol ].
ivnames := ivnames select: [:e |
  self _validateNewClassInstVar: e
  ].
oldEnd := instVars + 1.
self _inheritCIVs: ivnames at: oldEnd.
%

category: 'Class Instance Variables'
method: Metaclass
_inheritCIVs: ivnames at: inheritedIVIndex

"Adds the instance variables specified in the argument to the receiver at the
 given location.

 Instance variables that are added to a Metaclass are called
 Class Instance Variables."

| constr names vname subClss |

ivnames size == 0 ifTrue: [ ^self ].
constr := #[Object].
names := Array withAll: instVarNames.
1 to: ivnames size do: [:i |
  vname := ( ivnames at: i) asSymbol .
  names insertObject: vname at: (inheritedIVIndex + i - 1).
  self _unsafeAt: 3 put: instVars+1.   " at:GC_BEHAVIOR_INST_VARS "
  self _unsafeAt: 4 put: (InvariantArray withAll: names).
  self _unsafeAt: 5 put: constraints + constr.
  "force the class to increase in size by storing one position off the end"
  self _refreshClassCache.
  thisClass _insertCivAt: (inheritedIVIndex + i - 1).
  ].
thisClass _refreshClassCache.
thisClass subclassesDisallowed ifFalse: [
  subClss := self _subclasses.
  subClss ~~ nil ifTrue:[
    subClss do: [:e |
      e _inheritCIVs: ivnames at: inheritedIVIndex.
      ].
    ].
  ].
"finally, recompile my methods to ensure that the instance variable indexes are
 correct"
self _recompileMethodsAfterNewIvOffset: inheritedIVIndex.
%

category: 'Accessing'
method: Metaclass
_subclasses

""

"If thisClass is tracking subclasses, returns the corresponding list
 of Metaclasses."

| res |
res := thisClass _subclasses.
res ~~ nil ifTrue: [
  res := res collect: [:e | e class].
  ].
^res
%

category: 'Class Instance Variables'
method: Metaclass
_validateNewClassInstVar: ivname

"Returns true if the name passes all tests.  Generates errors if the name fails
 due to a) being an invalid identifier or b) being a duplicate of an existing
 instance variable, either in this Metaclass or in one of this Metaclass's
 instance's subclasses Metaclasses."

| subs |
((ivname size == 0 
  _or: [ivname isValidIdentifier not]) 
  _or:[ ivname _isSymbol not]) ifTrue: [
  self _error: #classErrBadIdentifier args: #[ivname].
  ^false
  ].
(instVarNames includesIdentical: ivname) ifTrue: [
  self _error: #rtErrAddDupInstvar args: #[ivname].
  ^false
  ].
thisClass isModifiable ifTrue: [
  subs := self _subclasses.
  subs ~~ nil ifTrue: [
    subs do: [:sub |
      (sub _validateNewClassInstVar: ivname) ifFalse: [ ^false ]
      ].
    ].
  ].
^true
%

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

"Reimplemented to treat class instance variables specially.  Nonmodifiable
 classes are made temporarily modifiable while a class instance variable
 is updated."

| newLine accessing updating allVarNames varName symlst |

accessing := Symbol withAll: 'Accessing'.
updating := Symbol withAll: 'Updating'.
symlst := SymbolList new.
varName := 'newValue'.
allVarNames := self allInstVarNames.
[allVarNames includesValue: varName] whileTrue: [
  varName := 'z' , varName.
].
newLine:= Character lf asString.
anArrayOfSymbols do: [ :var |
  (self compileMethod: (var , newLine , newLine ,
    '   "Return the value of the instance variable ''' , var ,
    '''."' , newLine , '   ^' , var , newLine)
    dictionaries: symlst
    category: accessing) == nil
  ifFalse: [
   self _error: #classErrNotAVar args: #[var]
  ].
  (allVarNames indexOfValue: var) > Metaclass.instVars ifTrue: [ | methodtext |
    "compile a method that lets the variable be modified if the user has
     the proper authority"
    methodtext := String new 
      addAll: var; addAll: ': '; addAll: varName; addAll: newLine;
      addAll: '  "changes the value of the receiver''s class instance variable ''';
      addAll: var; addAll: '''"'; addAll: newLine;
      addAll: newLine;
      addAll: '  self atClassInstVar: #'; addAll: var;
      addAll: ' put: '; addAll: varName; addAll: newLine;
      yourself.
    (self compileMethod: methodtext
      dictionaries: symlst
      category: updating) == nil
    ifFalse: [
      self _error: #classErrNotAVar args: #[var]
    ].
  ]
  ifFalse: [
    (self compileMethod: (var , ': ' , varName , newLine , newLine ,
      '   "Modify the value of the instance variable ''' , var ,
      '''."' , newLine , '   ' , var , ' := ' , varName , newLine)
      dictionaries: symlst
      category: updating) == nil
    ifFalse: [
      self _error: #classErrNotAVar args: #[var]
    ].
  ].
].
%

category: 'Displaying'
method: Metaclass
instanceString

"Returns a string that can be used to name an instance of the receiver.  Since
 the receiver has one instance, returns the name of that instance."

^thisClass name
%

category: 'Displaying'
method: Metaclass
instanceSymbol

"Returns a symbol that can be used to name an instance of the receiver.  Since
 a Metaclass has only one instance, returns the name of that instance."

^thisClass name
%

category: 'Queries'
method: Metaclass
isMeta

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

^true
%

category: 'Accessing'
method: Metaclass
extraDict

"Returns the extraDict of the receiver's sole instance.  See Class | extraDict."

^thisClass extraDict
%

category: 'Category'
method: Metaclass
_classCategory 

"Returns the classCategory of the receiver."

^ thisClass _classCategory
%

category: 'Private'
method: Metaclass
_subclasses

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

| subclss result |

subclss := thisClass _subclasses .
subclss == nil ifTrue:[ ^ nil ].
result := IdentitySet new .
subclss do:[ :aClass | result add: aClass class ].
^ result
%

category: 'Private'
method: Metaclass
_gbsTraversalCallback

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

^self printString
%

! deleted  Metaclass >> convertTo5
