--- a/Smalltalk.st Wed Sep 02 06:45:47 2015 +0200
+++ b/Smalltalk.st Sat Sep 05 09:15:28 2015 +0100
@@ -1,5 +1,3 @@
-"{ Encoding: utf8 }"
-
"
COPYRIGHT (c) 1988 by Claus Gittinger
All Rights Reserved
@@ -1274,6 +1272,114 @@
!Smalltalk class methodsFor:'class management'!
+basicRemoveClass:aClass
+ "remove the argument, aClass from the smalltalk dictionary;
+ we have to flush the caches since these methods are now void.
+ Also, class variables of aClass are removed."
+
+ |sym cSym names oldName oldNameSym actualName wrongName|
+
+ aClass isNil ifTrue:[^ self].
+
+ oldName := aClass name.
+ sym := oldNameSym := oldName asSymbol.
+ ((self at:oldNameSym) == aClass) ifFalse:[
+ "check other name ..."
+ (self includes:aClass) ifFalse:[
+ 'Smalltalk [warning]: no such class: ' errorPrint. oldName errorPrintCR.
+ ^ self
+ ].
+ "
+ the class has changed its name - without telling me ...
+ what should be done in this case ?
+ "
+ 'Smalltalk [warning]: class ' errorPrint. oldName errorPrint.
+ ' has changed its name' errorPrintCR.
+
+ "/
+ "/ might be an alias (i.e. removing a compatibility name)
+ "/
+ actualName := self keyAtValue:aClass.
+ ('Smalltalk [info]: ' , oldName , ' is actually stored as ' , actualName , '.') infoPrintCR.
+ sym := actualName asSymbol.
+ oldName := actualName asString.
+ wrongName := true.
+ ].
+
+ aClass isBuiltInClass ifTrue:[
+ self error: 'Cannot remove builtin class!!'.
+ ].
+ self at:sym put:nil. "nil it out for compiled accesses"
+
+ "/
+ "/ see comment in removeKey: on why we dont remove it here
+ "/
+ "/ self removeKey:sym. "/ remove key - this actually fails, if there are
+ "/ still compiled code references."
+
+ "remove private classes"
+
+ aClass privateClassesSorted do:[:somePrivateClass |
+ aClass privateClassesAt:(somePrivateClass nameWithoutPrefix) asSymbol put:nil.
+ ].
+
+ "remove class variables"
+
+ names := aClass classVariableString asCollectionOfWords.
+ names do:[:name |
+ cSym := aClass globalKeyForClassVar:name.
+ self at:cSym asSymbol put:nil.
+
+ "/
+ "/ see comment in removeKey: on why we dont remove it here
+ "/
+ "/ self removeKey:cSym
+ ].
+
+
+"/ actually could get along with less flushing
+"/ (entries for aClass and subclasses only)
+"/ but we have to delay this, until we have the set of subclasses
+"/ at hand - for now, searching for all subclasses is way more
+"/ expensive then cache flushing.
+"/
+"/ aClass allSubclassesDo:[:aSubclass |
+"/ ObjectMemory flushInlineCachesForClass:aSubclass.
+"/ ObjectMemory flushMethodCacheFor:aSubclass
+"/ ].
+"/ ObjectMemory flushInlineCachesForClass:aClass.
+"/ ObjectMemory flushMethodCacheFor:aClass
+
+ ObjectMemory flushInlineCaches.
+ ObjectMemory flushMethodCache.
+
+ aClass addChangeRecordForClassRemove.
+ self changed:#classRemove with:aClass.
+
+ aClass setCategory:#'* removed *'.
+
+"/ self flushCachedClasses.
+"/ Class flushSubclassInfo.
+ self flushCachedClass:aClass.
+ Class flushSubclassInfoFor:aClass superclass.
+ Class flushSubclassInfoFor:aClass.
+
+ wrongName == true ifTrue:[
+ "/
+ "/ an alias (i.e. removing a compatibility name)
+ "/
+ "/ check if there are more refs to it ...
+ [self includes:aClass] whileTrue:[
+ actualName := self keyAtValue:aClass.
+ ('Smalltalk [info]: ' , aClass name , ' is also registered under the name ' , actualName
+ , ' - remove that binding too.') infoPrintCR.
+ self at:actualName put:nil.
+ ].
+ ].
+
+ "Modified: / 18-11-2006 / 17:16:31 / cg"
+!
+
changeCategoryOf:aClass to:newCategory
"change a classes category, add a change record,
send change notifications"
@@ -1321,130 +1427,79 @@
removeClass:aClass
"remove the argument, aClass from the smalltalk dictionary;
we have to flush the caches since these methods are now void.
- Also, class variables of aClass are removed."
-
- |sym cSym names oldName oldNameSym actualName wrongName ns ons|
-
- aClass isNil ifTrue:[^ self].
-
- oldName := aClass name.
- sym := oldNameSym := oldName asSymbol.
- ((self at:oldNameSym) == aClass) ifFalse:[
- "check other name ..."
- (self includes:aClass) ifFalse:[
- 'Smalltalk [warning]: no such class: ' errorPrint. oldName errorPrintCR.
- ^ self
- ].
- "
- the class has changed its name - without telling me ...
- what should be done in this case ?
- "
- 'Smalltalk [warning]: class ' errorPrint. oldName errorPrint.
- ' has changed its name' errorPrintCR.
-
- "/
- "/ might be an alias (i.e. removing a compatibility name)
- "/
- actualName := self keyAtValue:aClass.
- ('Smalltalk [info]: ' , oldName , ' is actually stored as ' , actualName , '.') infoPrintCR.
- sym := actualName asSymbol.
- oldName := actualName asString.
- wrongName := true.
- ].
-
+ Also, class variables of aClass are removed.
+ Recompile accessors to aClass."
+
+ |oldNameSym ns ons|
+
+ oldNameSym := aClass name asSymbol.
ns := aClass nameSpace.
aClass topOwningClass notNil ifTrue:[
- ons := aClass topOwningClass nameSpace
- ].
- aClass isBuiltInClass ifTrue:[
- self error: 'Cannot remove builtin class!!'.
- ].
-
- self at:sym put:nil. "nil it out for compiled accesses"
-
- "/
- "/ see comment in removeKey: on why we dont remove it here
- "/
- "/ self removeKey:sym. "/ remove key - this actually fails, if there are
- "/ still compiled code references."
-
- "remove private classes"
-
- aClass privateClassesSorted do:[:somePrivateClass |
- aClass privateClassesAt:(somePrivateClass nameWithoutPrefix) asSymbol put:nil.
- ].
-
- "remove class variables"
-
- names := aClass classVariableString asCollectionOfWords.
- names do:[:name |
- cSym := aClass globalKeyForClassVar:name.
- self at:cSym asSymbol put:nil.
-
- "/
- "/ see comment in removeKey: on why we dont remove it here
- "/
- "/ self removeKey:cSym
- ].
-
-
-"/ actually could get along with less flushing
-"/ (entries for aClass and subclasses only)
-"/ but we have to delay this, until we have the set of subclasses
-"/ at hand - for now, searching for all subclasses is way more
-"/ expensive then cache flushing.
-"/
-"/ aClass allSubclassesDo:[:aSubclass |
-"/ ObjectMemory flushInlineCachesForClass:aSubclass.
-"/ ObjectMemory flushMethodCacheFor:aSubclass
-"/ ].
-"/ ObjectMemory flushInlineCachesForClass:aClass.
-"/ ObjectMemory flushMethodCacheFor:aClass
-
- ObjectMemory flushInlineCaches.
- ObjectMemory flushMethodCache.
-
- aClass addChangeRecordForClassRemove.
- self changed:#classRemove with:aClass.
-
- aClass setCategory:#'* removed *'.
-
-"/ self flushCachedClasses.
-"/ Class flushSubclassInfo.
- self flushCachedClass:aClass.
- Class flushSubclassInfoFor:aClass superclass.
- Class flushSubclassInfoFor:aClass.
-
- wrongName == true ifTrue:[
- "/
- "/ an alias (i.e. removing a compatibility name)
- "/
- "/ check if there are more refs to it ...
- [self includes:aClass] whileTrue:[
- actualName := self keyAtValue:aClass.
- ('Smalltalk [info]: ' , aClass name , ' is also registered under the name ' , actualName
- , ' - remove that binding too.') infoPrintCR.
- self at:actualName put:nil.
- ].
- ].
+ ons := aClass topOwningClass nameSpace
+ ].
+
+ self basicRemoveClass:aClass.
ns ~~ Smalltalk ifTrue:[
- ons notNil ifTrue:[
- ClassBuilder
- recompileGlobalAccessorsTo:oldNameSym
- in:ons
- except:nil
- ].
- (ns notNil and:[ns ~~ ons]) ifTrue:[
- ClassBuilder
- recompileGlobalAccessorsTo:oldNameSym
- in:ns
- except:nil
- ].
- ].
-
- "Modified: / 18-11-2006 / 17:16:31 / cg"
- "Modified: / 20-04-2015 / 17:20:47 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ ons notNil ifTrue:[
+ ClassBuilder
+ recompileGlobalAccessorsTo:oldNameSym
+ in:ons
+ except:nil
+ ].
+ (ns notNil and:[ns ~~ ons]) ifTrue:[
+ ClassBuilder
+ recompileGlobalAccessorsTo:oldNameSym
+ in:ns
+ except:nil
+ ].
+ ].
+!
+
+removeClasses:aCollectionOfClasses
+ "remove aCollectionOfClasses from the smalltalk dictionary;
+ we have to flush the caches since these methods are now void.
+ Also, class variables of aClass are removed.
+ Recompile accessors to the classes - after all classes in the collection have been removed."
+
+ |tuples|
+
+ tuples := aCollectionOfClasses collect:[:eachClass|
+ Array
+ with:eachClass name asSymbol
+ with:eachClass nameSpace
+ with:(
+ eachClass topOwningClass notNil ifTrue:[
+ eachClass topOwningClass nameSpace
+ ] ifFalse:[nil])
+ ].
+
+ aCollectionOfClasses do:[:eachClass|
+ self basicRemoveClass:eachClass.
+ ].
+
+ tuples do:[:eachClssymNsOnsTuple|
+ |oldNameSym ns ons|
+
+ oldNameSym := eachClssymNsOnsTuple at:1.
+ ns := eachClssymNsOnsTuple at:2.
+ ons := eachClssymNsOnsTuple at:3.
+
+ ns ~~ Smalltalk ifTrue:[
+ ons notNil ifTrue:[
+ ClassBuilder
+ recompileGlobalAccessorsTo:oldNameSym
+ in:ons
+ except:nil
+ ].
+ (ns notNil and:[ns ~~ ons]) ifTrue:[
+ ClassBuilder
+ recompileGlobalAccessorsTo:oldNameSym
+ in:ns
+ except:nil
+ ].
+ ]
+ ].
!
renameClass:aClass to:newName
@@ -4867,8 +4922,10 @@
language:aLanguageSymbol
"set the language - send out change notifications"
- Language := aLanguageSymbol asSymbol.
- self changed:#Language
+ aLanguageSymbol ~= Language ifTrue:[
+ Language := aLanguageSymbol asSymbol.
+ self changed:#Language
+ ].
"
Smalltalk language:#de
@@ -4880,9 +4937,11 @@
language:aLanguageSymbol territory:aTerritorySymbol
"set the language & territory - send out change notifications"
- Language := aLanguageSymbol asSymbol.
- LanguageTerritory := aTerritorySymbol asSymbol.
- self changed:#Language
+ ((Language ~= aLanguageSymbol) or:[ LanguageTerritory ~= aTerritorySymbol]) ifTrue:[
+ Language := aLanguageSymbol asSymbol.
+ LanguageTerritory := aTerritorySymbol asSymbol.
+ self changed:#Language
+ ].
"
Smalltalk language:#de territory:#de
@@ -8026,13 +8085,13 @@
(lang == #de) ifTrue:[
proto := 'Willkommen bei %1 (Version %2 von %3)'
] ifFalse:[ (lang == #fr) ifTrue:[
- proto := 'Salut, Bienvenue à %1 (version %2 de %3)'
+ proto := 'Salut, Bienvenue à %1 (version %2 de %3)'
] ifFalse:[ (lang == #it) ifTrue:[
proto := 'Ciao, benvenuto al %1 (versione %2 di %3)'
] ifFalse:[ (lang == #es) ifTrue:[
-"/ proto := 'Hola, bienvenida a %1 (versión %2 de %3)'
+"/ proto := 'Hola, bienvenida a %1 (versión %2 de %3)'
] ifFalse:[ (lang == #es) ifTrue:[
-"/ proto := 'Oi, benvindo a %1 (versão %2 de %3)'
+"/ proto := 'Oi, benvindo a %1 (versão %2 de %3)'
] ifFalse:[ (lang == #no) ifTrue:[
proto := 'Hei, verdenmottakelse til %1 (versjon %2 av %3)'
]]]]]].