!=========================================================================
! Copyright (C) VMware, Inc. 1986-2011.  All Rights Reserved.
!
! $Id: sessionmethods.topaz,v 1.15 2008-01-09 22:50:15 stever Exp $
!
! sessionmethods.topaz  -  session method support
!
!   Initial set of basic method overrides that live in session methods
!
!========================================================================

!
! Packages are stored in #CodeLibrary SymbolList in DataCurator's UserGlobals
!
set user DataCurator pass swordfish
login

!
! define global that contains the name of the SessionMethods
!
expectvalue true
doit
UserGlobals at: #Gs_PackageName_Current put: #'SessionMethods'.
^true
%

!
! Create SessionMethods SymbolDictionary
!
expectvalue %GsPackagePolicy
run
| package policy |
package := GsPackageLibrary createPackageNamed: Gs_PackageName_Current.
package initialize.
GsPackageLibrary installPackage: package enable: false.
GsPackagePolicy initialize.
GsPackagePolicy current refreshSessionMethodDictionary.
policy := GsPackagePolicy current.
policy enable.
policy homeSymbolDict: package symbolDict.
policy externalSymbolList: (GsSession currentSession symbolList asArray copyWithout: package symbolDict).
%
!
! Insert GsPackagePolicy logic into the system as a session method
!
expectValue true
doit
| policy sourceString selector methodDict categoryDict result |
policy := GsPackagePolicy current.
selector := #compileMethod:dictionaries:category: .

"Note this method is filed in _AGAIN_ later on in the filein, to enable the timestamp logic
 which is commented out in this version"
sourceString := 
'compileMethod: sourceString
dictionaries: aSymbolList
category: aCategoryString

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

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

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

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

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

| symList categ result mDict cDict |

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

mDict := cDict := nil.
GsPackagePolicy current
	methodAndCategoryDictionaryFor: self 
	source: sourceString 
	dictionaries: aSymbolList 
	category: categ 
	do: [:m :c :errorArray | mDict := m. cDict := c. result := errorArray ].
result ~~ nil ifTrue: [ ^result "error during parsing" ].
mDict ~~ nil
    ifTrue: [
        result := self compileMethod: sourceString
                dictionaries: symList
                category: categ  intoMethodDict: mDict intoCategories: cDict
		intoPragmas: nil .
        result _class == GsMethod 
            ifTrue:[ 
                GsPackagePolicy current updateMethodLookupCacheFor: result in: self.
                "GsPackagePolicy current 
                        setStamp: self changeStamp 
                        forBehavior: self
                        forMethod: result selector."
                result := nil.
            ].
    ]
    ifFalse: [
        Segment setCurrent: self segment while:[
            result := self compileMethod: sourceString
                dictionaries: symList
                category: categ  intoMethodDict: nil intoCategories: nil
	        intoPragmas: nil .
            result _class == GsMethod 
                ifTrue:[ 
                    "self setStamp: self changeStamp forMethod: result selector."
                    result := nil 
                ].
        ].
    ].
^ result
'.
policy 
	methodAndCategoryDictionaryFor: Behavior
	source: sourceString 
	dictionaries: System myUserProfile symbolList 
	category: #'Updating the Method Dictionary'
	do: [:m :c :errorArray | methodDict := m. categoryDict := c. result := errorArray ].
result ~~ nil ifTrue: [ ^result halt: 'compiler error' ].
result := Behavior 
	compileMethod: sourceString
	dictionaries: System myUserProfile symbolList
	category: #'Updating the Method Dictionary'
 	intoMethodDict: methodDict
	intoCategories: categoryDict intoPragmas: nil .
^result class == GsMethod
%

commit

expectvalue true
doit
GsPackagePolicy current refreshSessionMethodDictionary.
^true
%

!
! Session method support - should be installed as session methods
!

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

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

| sels oldsym newsym seg canWrite |

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

seg := self segment.
canWrite := (seg == nil
  ifTrue: [ true ]
  ifFalse: [ seg currentUserCanWrite ]).
newsym := newName asSymbol.
canWrite
  ifTrue: [
    (categories includesKey: newsym) ifTrue: [
      sels size downTo: 1 do: [ :i |
        self moveMethod: (sels at: i) toCategory: newsym
      ].
      categories removeKey: oldsym ifAbsent: [].
    ]
    ifFalse: [
      (categories includesKey: oldsym) ifTrue: [
        categories add:
    	(SymbolAssociation new key: newsym value: (categories at: oldsym)).
        categories removeKey: oldsym.
      ].
    ].
  ]
  ifFalse: [
    (self _categories includesKey: newsym) ifTrue: [
      sels size downTo: 1 do: [ :i |
        self moveMethod: (sels at: i) toCategory: newsym
      ].
      GsPackagePolicy current removeCategory: oldsym for: self.
      categories removeKey: oldsym ifAbsent: [].
    ]
    ifFalse: [
      (self categories includesKey: oldsym) ifTrue: [ | oldCatSet catSet |
        oldCatSet := self _categories at: oldsym.
        catSet := self _addCategory: newsym.
        catSet addAll: oldCatSet.
        GsPackagePolicy current removeCategory: oldsym for: self.
        categories removeKey: oldsym.
      ].
    ].
  ].
%
category: 'Updating Categories'
method: Behavior
renameCategory: categoryName to: newCategoryName

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

| catDict |
self _validatePrivilege.
catDict := self _categories.
(catDict includesKey: (newCategoryName asSymbol))
ifTrue: [^ self _error: #classErrMethCatExists args: #[newCategoryName, self]].

(catDict includesKey: (categoryName asSymbol))
ifTrue: [ | seg canWrite |
  seg := self segment.
  canWrite := (seg == nil
    ifTrue: [ true ]
    ifFalse: [ seg currentUserCanWrite ]).
  canWrite
    ifTrue: [
      categories add: (SymbolAssociation newWithKey: (newCategoryName asSymbol)
                                      value: (categories at: categoryName)).
      categories removeKey: categoryName.
    ]
    ifFalse: [ | oldCatSet catSet catSym |
      catSym := categoryName asSymbol.
      oldCatSet := self _categories at: catSym.
      catSet := self _addCategory: newCategoryName asSymbol.
      catSet addAll: oldCatSet.
      GsPackagePolicy current removeCategory: catSym for: self.
      categories removeKey: catSym ifAbsent: [].
    ].
 ]
ifFalse: [
   "key not found"
   ^ self _error: #classErrMethCatNotFound
            args: #[categoryName]
   ]
%
category: 'Updating Categories'
method: Behavior
moveMethod: aSelector toCategory: categoryName

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

| catDict theKeys index oldCateg newCateg theSize selectorSym |

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

self _validatePrivilege.
catDict := self _categories.
newCateg:= catDict at: categoryName asSymbol .

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

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

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

(newCateg includesValue: selectorSym) "add aSelector"
ifTrue: [
  "selector already there, unlikely"
  self _uncontinuableError .
  ]
ifFalse: [newCateg add: selectorSym]
%
category: 'Updating Categories'
method: Behavior
removeCategory: categoryName

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

| theSelectors catSym |

self _validatePrivilege.
theSelectors := (self _categories at: (categoryName asSymbol)) copy.
1 to: theSelectors size do: [ :each |
  self _basicRemoveSelector: (theSelectors at: each)
  ].
catSym := categoryName asSymbol.
GsPackagePolicy current removeCategory: catSym for: self.
categories removeKey: catSym ifAbsent: []
%
category: 'Updating Categories'
method: Behavior
addCategory: aString

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

self _validatePrivilege.
aSymbol := aString asSymbol .
(self _includesCategory: aSymbol)
ifTrue:[ ^ self _error: #classErrMethCatExists
                  args: #[aString, self]]. "category already exists for class"
seg := self segment.
canWrite := (seg == nil
		ifTrue: [ true ]
		ifFalse: [ seg currentUserCanWrite ]).
canWrite
  ifTrue: [ categories add: (SymbolAssociation newWithKey: aSymbol value: SymbolSet new ) ]
  ifFalse: [ GsPackagePolicy current addCategory: aSymbol for: self ].
%
category: 'Browser Methods'
method: Behavior
_addCategory: categoryName

"Returns the Array representing the new category."

self _validatePrivilege.
self addCategory: categoryName .
^ self _categories at: categoryName asSymbol
%
category: 'Browser Methods'
method: Behavior
_selectorWithSource: aString

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

self _methodDict keysAndValuesDo:[:aSelector :aMethod |
  (aMethod _sourceString == aString) ifTrue: [^ aSelector ]
  ].
^nil
%
category: 'Browser Methods'
method: Behavior
_categoriesReport

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

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

| result assocs anAssoc k |
assocs := IdentitySet new .
self _categories keysAndValuesDo:[:categName :selectors| | sortedSelectors |
  sortedSelectors := SortedCollection new .
  selectors do:[:aSelector| sortedSelectors add: aSelector ].
  sortedSelectors := Array withAll: sortedSelectors .
  assocs add: (SymbolAssociation newWithKey: categName value: sortedSelectors) 
  ].
assocs := assocs sortAscending: 'key' .
result := Array new: assocs size * 2  .
k := 1 .
1 to: assocs size do:[:j | 
 anAssoc := assocs at: j . 
 result at: k put: anAssoc key .
 result at: k + 1 put: anAssoc value .
 k := k + 2 .
 ].
^ result .
%
category: 'Accessing Categories'
method: Behavior
removeSelector: aString ifAbsent: aBlock

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

| aKey |

self _validatePrivilege.
aKey := aString asSymbol .
(self _methodDict includesKey: aKey) ifFalse:[ ^ aBlock value ] .
self removeSelector: aKey .
%
category: 'Accessing Categories'
method: Behavior
categoryNames

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

 | result |
 result := Set new: categories size .
 categories keysAndValuesDo:[ :aKey :aValue |
   result add: aKey .
   ]. 
 GsPackagePolicy current categoryNamesFor: self into: result.
 ^ result asArray
%
category: 'Accessing Categories'
method: Behavior
selectorsIn: categoryName

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

 | set |
 set := Set withAll: (categories at: (categoryName asSymbol) otherwise: #()).
 GsPackagePolicy current selectorsIn: categoryName for: self into: set.
 ^set asArray
%
category: 'Accessing Categories'
method: Behavior
sortedCategoryNames

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

 | coll |
 coll := SortedCollection new .
 coll addAll: self categoryNames.
 ^ Array withAll: coll .
%
category: 'Accessing Categories'
method: Behavior
sortedSelectorsIn: categoryName

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

 | coll |
 coll := SortedCollection new .
 coll addAll: (self selectorsIn: categoryName).
 ^ Array withAll: coll
%
category: 'Accessing Categories'
method: Behavior
_includesCategory: aString

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

^ self categoryNames includes: aString asSymbol
%
category: 'Accessing Categories'
method: Behavior
_categories

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

 | catDict |
 catDict := categories copy.
 GsPackagePolicy current copyCategoryDictFor: self into: catDict.
 ^ catDict
%
category: 'Accessing the Method Dictionary'
method: Behavior
allSelectors

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

| result currClass meths |

(superClass == nil)
ifTrue:
   [^ self selectors]
ifFalse:
   [ result:= Array new.
     currClass:= self.
     [ currClass == nil ]
     whileFalse:
     [ meths := currClass selectors asSet.
       GsPackagePolicy current selectorsFor: currClass into: meths.
       result insert: meths asArray at: 1.
       currClass:= currClass superClass.
     ].
   ].
^ result
%
category: 'Accessing the Method Dictionary'
method: Behavior
categoryOfSelector: aSelector

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

| aSymbol cat |
aSymbol := Symbol _existingWithAll: aSelector .
aSymbol == nil ifTrue:[ ^ nil ].
cat := GsPackagePolicy current categoryOfSelector: aSymbol for: self.
cat ~~ nil ifTrue: [ ^cat ].
categories keysAndValuesDo: [:aKey :aValue | 
  (aValue includesIdentical: aSymbol ) ifTrue:[ ^ aKey ].
  ].
^ nil
%
category: 'Accessing the Method Dictionary'
method: Behavior
compiledMethodAt: aSelector

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

| aSym meth |
aSym := Symbol _existingWithAll: aSelector.
aSym == nil ifTrue:[ ^ methodDict _errorKeyNotFound: aSelector ].
meth := GsPackagePolicy current compiledMethodAt: aSym for: self.
meth ~~ nil ifTrue: [ ^meth ].
^ methodDict at: aSym
%
category: 'Accessing the Method Dictionary'
method: Behavior
includesSelector: aString

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

| aSym aBool |
aSym := Symbol _existingWithAll: aString.
aSym == nil ifTrue:[ ^ false ].
aBool := GsPackagePolicy current includesSelector: aSym for: self.
aBool ifTrue: [ ^true ].
^ methodDict includesKey: aSym 
%
category: 'Accessing the Method Dictionary'
method: Behavior
selectors

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

 | set |
 set := Set withAll: (methodDict keys).
 GsPackagePolicy current selectorsFor: self into: set.
 ^set asArray
%
category: 'Accessing the Method Dictionary'
method: Behavior
sourceCodeAt: aSelector

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

|method aSym|

aSym := Symbol _existingWithAll: aSelector.
aSym == nil ifTrue:[ ^ methodDict _errorKeyNotFound: aSelector ].
method := GsPackagePolicy current compiledMethodAt: aSym for: self.
method ~~ nil ifTrue: [ ^method _sourceString ].
((method:= methodDict at: aSym ) ~~ nil)
ifTrue:
   [^ method _sourceString]
ifFalse:
   [^ nil]
%
category: 'Accessing the Method Dictionary'
method: Behavior
_rawMethodDict

"Returns the method dictionary."

 ^methodDict
%
category: 'Accessing the Method Dictionary'
method: Behavior
whichClassIncludesSelector: aString

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

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

  policy := GsPackagePolicy current.
  "Check the immediate class directly"
  (policy includesSelector: aSymbol for: self) ifTrue: [ ^self ].
  (methodDict includesKey: aSymbol) ifTrue: [^self].

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

  [ currClass == nil ifTrue: [^nil].
    (policy includesSelector: aSymbol for: currClass) ifTrue: [^currClass ].
    currClass _rawMethodDict includesKey: aSymbol]
  whileFalse:
    [ currClass := currClass superClass ].

  ^currClass

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

"Returns the method dictionary."

 | methDict |
 methDict := methodDict copy.
 GsPackagePolicy current copyMethodDictFor: self into: methDict.
^ methDict
%
category: 'Class Timestamps'
method: Behavior
commentStamp

	^self extraDict at: #GSClassCommentStamp ifAbsent: [nil]
%
category: 'Class Timestamps'
method: Behavior
commentStamp: aStamp
	"Set the receiver's comment timeStamp to aStamp."

	self theNonMetaClass extraDict at: #GSClassCommentStamp put: aStamp
%
category: 'Class Timestamps'
method: Behavior
theNonMetaClass
	"Sent to a class or metaclass, always return the class"

	^self
%
category: 'Method Timestamps'
method: Behavior
authorInitials
    ^GsPackagePolicy current authorInitials
%
category: 'Method Timestamps'
method: Behavior
changeStamp 
	"Answer a string to be pasted into source code to mark who changed it and when."
	^ self authorInitials , ' ' , (Date today asStringUsingFormat: #(2 1 3 $/ 1 1 $: false )), ' ',
		(Time now asString copyFrom: 1 to: 5)
%
category: 'Pragmas'
method: Behavior
setPragmas: pragmaArray forMethod: selector
	"Set the pragmas for the given method"

	| methodPragmaDict |
	(GsPackagePolicy current
			setPragmas: pragmaArray 
			forBehavior: self
			forMethod: selector) ~~ nil
		ifTrue: [ ^self ].
	methodPragmaDict := self extraDict at: #GSMethodPragmaDict ifAbsent: [nil].
	methodPragmaDict == nil 
		ifTrue: [ 
			methodPragmaDict := Dictionary new.
			self extraDict  at: #GSMethodPragmaDict put: methodPragmaDict.
		 ].
	pragmaArray == nil
		ifTrue: [ methodPragmaDict removeKey: selector asSymbol ifAbsent: [] ]
		ifFalse: [ methodPragmaDict at: selector asSymbol put: pragmaArray ]
%
category: 'Pragmas'
method: Metaclass
setPragmas: pragmaArray forMethod: selector
	"Set the pragmas for the given method"

	| methodPragmaDict |
	(GsPackagePolicy current
			setPragmas: pragmaArray 
			forBehavior: self
			forMethod: selector) ~~ nil
		ifTrue: [ ^self ].
	methodPragmaDict := thisClass extraDict at: #GSMetaMethodPragmaDict ifAbsent: [nil].
	methodPragmaDict == nil 
		ifTrue: [ 
			methodPragmaDict := Dictionary new.
			thisClass extraDict  at: #GSMetaMethodPragmaDict put: methodPragmaDict.
		 ].
	pragmaArray == nil
		ifTrue: [ methodPragmaDict removeKey: selector asSymbol ifAbsent: [] ]
		ifFalse: [ methodPragmaDict at: selector asSymbol put: pragmaArray ]
%
category: 'Method Timestamps'
method: Behavior
setStamp: aStamp forMethod: selector
	"Set the timestamp for the given method"

	| methodStampDict |
	(GsPackagePolicy current
			setStamp: aStamp 
			forBehavior: self
			forMethod: selector) ~~ nil
		ifTrue: [ ^self ].
	methodStampDict := self extraDict at: #GSMethodStampDict ifAbsent: [nil].
	methodStampDict == nil 
		ifTrue: [ 
			methodStampDict := Dictionary new.
			self extraDict  at: #GSMethodStampDict put: methodStampDict.
		 ].
	aStamp == nil
		ifTrue: [ methodStampDict removeKey: selector asSymbol ifAbsent: [] ]
		ifFalse: [ methodStampDict at: selector asSymbol put: aStamp ]
%
category: 'Pragmas'
method: Behavior
stampForMethod: selector
        "Get the timestamp for the given method"

        | stamp methodStampDict |
        stamp := GsPackagePolicy current stampForMethod: selector in: self.
        stamp ~~ nil ifTrue: [ ^stamp ].
        methodStampDict := self extraDict at: #GSMethodStampDict ifAbsent: [ ^'' ].
        ^methodStampDict at: selector asSymbol ifAbsent: [ '' ]
%
category: 'Pragmas'
method: Behavior
createPragmaFrom: aPragmaArray for: aGsMethod
    "Placeholder for creating an instance of Pragma"
    ^nil
%
category: 'Pragmas'
method: Behavior
pragmasForMethod: selector
        "Get the Pragmas for the given method"

        | pragmas methodPragmaDict |
        pragmas := GsPackagePolicy current pragmasForMethod: selector in: self.
        pragmas ~~ nil ifTrue: [ ^pragmas ].
        methodPragmaDict := self extraDict at: #GSMethodPragmaDict ifAbsent: [ ^#() ].
        ^methodPragmaDict at: selector asSymbol ifAbsent: [ #() ]
%
category: 'Updating the Method Dictionary'
method: Behavior
removeSelector: aString

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

| selector |

self _validatePrivilege.
(self _basicRemoveSelector: (selector := aString asSymbol))
	ifTrue: [
		categories associationsDo: [:anAssoc | | setOfSelectors |
  			setOfSelectors:= anAssoc value.
  			(setOfSelectors remove: selector ifAbsent:[ nil ]) ~~ nil ifTrue:[ 
    			^ self "done"
    			]
  		].
		"if we get here , we could not find the selector in any category "
		^ self _error: #classErrSelectorNotFound args: #[aString] .
	].
%
category: 'Updating the Method Dictionary'
method: Behavior
_basicRemoveSelector: aSymbol

"Private."
| oldMeth removedFromSelf |
self _validatePrivilege.
removedFromSelf := false.
(oldMeth := GsPackagePolicy current removeMethodAt: aSymbol for: self) == nil
	ifTrue: [
		oldMeth := methodDict removeKey: aSymbol . "runtime error here if key not found"
		removedFromSelf := true.
	].
self _refreshLookupCache: aSymbol oldMethod: oldMeth.
^removedFromSelf
%
category: 'Updating the Method Dictionary'
method: Behavior
removeAllMethods

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

self _validatePrivilege.
categories ~~ nil ifTrue: [ categories removeAll ].
methodDict ~~ nil ifTrue: [ 
  methodDict keysDo: [:sel | 
    self setStamp: nil forMethod: sel.
    self setPragmas: nil forMethod: sel ].
  methodDict removeAll.
].
GsPackagePolicy current removeAllMethodsFor: self.
self _refreshClassCache.
%
category: 'Modifying Classes'
method: Behavior
recompileAllMethodsInContext: aSymbolList

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

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

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

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

| theSubclasses |
self _validatePrivilege.
theSubclasses := self _subclasses .
theSubclasses ~~ nil ifTrue:[
  theSubclasses do:[:x| x _removeAllSubclassCode ] .
  ].
GsPackagePolicy current removeAllSubclassCodeFor: self.

methodDict keysAndValuesDo: [ :aKey :aMethod |
  methodDict at: aKey put: ((methodDict at: aKey) _copyToForceRecompilation).
  ].
self _refreshClassCache .
^ self
%
!------------- 

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

| cl |
cl := self 
	indexableSubclass: aString
	instVarNames: anArrayOfStrings
	classVars: anArrayOfClassVars
	classInstVars: anArrayOfClassInstVars
	poolDictionaries: anArrayOfPoolDicts
	inDictionary: aDictionary
	instancesInvariant: invarBoolean
	isModifiable: modifyBoolean.
cl category: aCategoryName asString.
^cl
%
category: 'Subclass Creation'
method: Class
byteSubclass: aString
classVars: anArrayOfClassVars
classInstVars: anArrayOfClassInstVars
poolDictionaries: anArrayOfPoolDicts
category: aCategoryName
inDictionary: aDictionary
instancesInvariant: invarBoolean

| cl |
cl := self 
	byteSubclass: aString
	classVars: anArrayOfClassVars
	classInstVars: anArrayOfClassInstVars
	poolDictionaries: anArrayOfPoolDicts
	inDictionary: aDictionary
	instancesInvariant: invarBoolean.
cl category: aCategoryName asString.
^cl
%
category: 'Subclass Creation'
method: Class
subclass: aString
instVarNames: anArrayOfStrings
classVars: anArrayOfClassVars
classInstVars: anArrayOfClassInstVars
poolDictionaries: anArrayOfPoolDicts
category: aCategoryName
inDictionary: aDictionary
constraints: aConstraint
instancesInvariant: invarBoolean
isModifiable: modifyBoolean

| cl |
cl := self subclass: aString
	instVarNames: anArrayOfStrings
	classVars: anArrayOfClassVars
	classInstVars: anArrayOfClassInstVars
	poolDictionaries: anArrayOfPoolDicts
	inDictionary: aDictionary
	constraints: aConstraint
	instancesInvariant: invarBoolean
	isModifiable: modifyBoolean.
cl category: aCategoryName asString.
^cl
%
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: [ $] ]).

"category: <name of class category>"

classCategory ~~ nil
    ifTrue: [
        result addAll: lfsp; addAll: 'category: '.
        result addAll: classCategory printString.
    ].

" 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: [
    (anArray at: 2) isValidIdentifier
	ifTrue: [
    		result addAll: (anArray at: 2).
	]
	ifFalse: [
    		result addAll: '(System myUserProfile symbolList objectNamed: '.
    		result addAll: (anArray at: 2) printString.
    		result addAll: ')'.
	].
  ]
].

" 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
%
!------------- 

!------------- Metaclass ------------------
category: 'Class Timestamps'
method: Metaclass
theNonMetaClass
	"Sent to a class or metaclass, always return the class"

	^thisClass
%
category: 'Class Timestamps'
method: Metaclass
commentStamp

	^thisClass commentStamp
%
category: 'Method Timestamps'
method: Metaclass
setStamp: aStamp forMethod: selector
	"Set the timestamp for the given method"

	| methodStampDict |
	(GsPackagePolicy current
			setStamp: aStamp 
			forBehavior: self
			forMethod: selector) ~~ nil
		ifTrue: [ ^self ].
	methodStampDict := thisClass extraDict at: #GSMetaMethodStampDict ifAbsent: [nil].
	methodStampDict == nil 
		ifTrue: [ 
			methodStampDict := Dictionary new.
			thisClass extraDict  at: #GSMetaMethodStampDict put: methodStampDict.
		 ].
	aStamp == nil
		ifTrue: [ methodStampDict removeKey: selector asSymbol ifAbsent: [] ]
		ifFalse: [ methodStampDict at: selector asSymbol put: aStamp ]
%
category: 'Method Timestamps'
method: Metaclass
stampForMethod: selector
   "Get the timestamp for the given method"

   | stamp methodStampDict |
   stamp := GsPackagePolicy current stampForMethod: selector in: self.
   stamp ~~ nil ifTrue: [ ^stamp ].
   methodStampDict := thisClass extraDict at: #GSMetaMethodStampDict ifAbsent: [ ^'' ].
   ^methodStampDict at: selector asSymbol ifAbsent: [ '' ]
%
category: 'Pragmas'
method: Metaclass
pragmasForMethod: selector
   "Get the pragmas for the given method"

   | pragmas methodPragmaDict |
   pragmas := GsPackagePolicy current pragmasForMethod: selector in: self.
   pragmas ~~ nil ifTrue: [ ^pragmas ].
   methodPragmaDict := thisClass extraDict at: #GSMetaMethodPragmaDict ifAbsent: [ ^#() ].
   ^methodPragmaDict at: selector asSymbol ifAbsent: [ #() ]
%
!------------- 

!------------- This method is filed in initially at the _BEGINNING_ of this filein
!------------- turn on the time stamp stuff, now that all the necessary methods are implemented
category: 'Updating the Method Dictionary'
method: Behavior
compileMethod: sourceString
dictionaries: aSymbolList
category: aCategoryString

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

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

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

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

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

| symList categ result mDict cDict pArray |

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

mDict := cDict := nil.
GsPackagePolicy current
	methodAndCategoryDictionaryFor: self 
	source: sourceString 
	dictionaries: aSymbolList 
	category: categ 
	do: [:m :c :errorArray | mDict := m. cDict := c. result := errorArray ].
result ~~ nil ifTrue: [ ^result "error during parsing" ].
pArray := Array new.
mDict ~~ nil
    ifTrue: [
        result := self compileMethod: sourceString
                dictionaries: symList
                category: categ  intoMethodDict: mDict intoCategories: cDict
		        intoPragmas: pArray .
        result _class == GsMethod 
            ifTrue: [
                GsPackagePolicy current updateMethodLookupCacheFor: result in: self.
                GsPackagePolicy current 
                        setStamp: self changeStamp 
                        forBehavior: self
                        forMethod: result selector.
                GsPackagePolicy current 
                        setPragmas: (self createPragmaFrom: pArray for: result)
                        forBehavior: self
                        forMethod: result selector.
                result := nil.
            ].
    ]
    ifFalse: [
        Segment setCurrent: self segment while:[
            result := self compileMethod: sourceString
                dictionaries: symList
                category: categ  intoMethodDict: nil intoCategories: nil
		        intoPragmas: pArray .
            result _class == GsMethod 
                ifTrue:[ 
                    self setStamp: self changeStamp forMethod: result selector.
                    self 
                      setPragmas: (self createPragmaFrom: pArray for: result) 
                      forMethod: result selector.
                    result := nil 
                ].
        ].
    ].
^ result
%

!
! disable SessionMethods ... 
!
doit
GsPackagePolicy current disable.
^true
%

!
! Restore the DataCurators symbolList to its normal state
!
doit
GsPackageLibrary uninstallPackageAndPrereqs: (GsPackageLibrary packageNamed: Gs_PackageName_Current).
UserGlobals removeKey: #Gs_PackageName_Current ifAbsent: [].
UserGlobals removeKey: GsPackagePolicy globalName ifAbsent: [].
^true
%

commit
logout
errorCount

