--- a/ClassBuilder.st Tue Feb 04 21:09:59 2014 +0100
+++ b/ClassBuilder.st Wed Apr 01 10:20:10 2015 +0100
@@ -1,3 +1,5 @@
+"{ Encoding: utf8 }"
+
"
COPYRIGHT (c) 2001 by eXept Software AG
All Rights Reserved
@@ -11,6 +13,8 @@
"
"{ Package: 'stx:libbasic' }"
+"{ NameSpace: Smalltalk }"
+
Object subclass:#ClassBuilder
instanceVariableNames:'metaclass classClass className environment superClass
instanceVariableNames flags classVariableNames poolDictionaries
@@ -292,6 +296,7 @@
LastNamespaceName := aNamespace name.
LastClassNamesInNameSpace := privateClassNames asOrderedCollection.
].
+ privateClassNames := privateClassNames reject:[:nm | nm isNil].
privateClassNames do:[:eachClassName |
"the classes inside the namespace"
@@ -346,10 +351,12 @@
variableBoolean := wordsBoolean := pointersBoolean := false.
type ~~ #normal ifTrue:[
- type == #words ifTrue:[
- wordsBoolean := true
- ] ifFalse:[
+ type == #bytes ifFalse:[
+ type == #words ifTrue:[
+ wordsBoolean := true
+ ] ifFalse:[
self halt:'todo'.
+ ]
]
].
@@ -557,7 +564,9 @@
oldClass isLoaded ifTrue:[
oldClass category ~= category ifTrue:[
oldClass instanceVariableString asCollectionOfWords ~= instanceVariableNames asCollectionOfWords ifTrue:[
- (self confirm:'a class named ' , oldClass name , ' already exists -\\create (i.e. change) anyway ?' withCRs)
+ (self confirm:('A class named %1 already exists in category "%2".\\Create (i.e. change) anyway?' withCRs
+ bindWith:oldClass name allBold
+ with:oldClass category))
ifFalse:[
^ nil
]
@@ -668,8 +677,8 @@
newInstVars := newClass instanceVariableString asCollectionOfWords.
oldClassInstVars := oldClass class instanceVariableString asCollectionOfWords.
newClassInstVars := newClass class instanceVariableString asCollectionOfWords.
- oldClassVars := oldClass classVariableString asCollectionOfWords.
- newClassVars := newClass classVariableString asCollectionOfWords.
+ oldClassVars := oldClass classVariableString asCollectionOfWords asSet.
+ newClassVars := newClass classVariableString asCollectionOfWords asSet.
oldPoolDictionaries := oldClass sharedPoolNames.
newPoolDictionaries := newClass sharedPoolNames.
poolChange := (oldPoolDictionaries ~= newPoolDictionaries).
@@ -1056,8 +1065,7 @@
self class copyMethodsFrom:oldClass for:newClass
]
] ifTrue:[
-
- "/ dont allow built-in classes to be modified
+ "/ don't allow built-in classes to be modified
(instVarChange and:[oldClass notNil and:[oldClass isBuiltInClass]]) ifTrue:[
ClassBuildError raiseErrorString:'The layout of this class is fixed - you cannot change it.'.
@@ -1066,7 +1074,6 @@
((oldInstVars size == 0)
or:[newInstVars startsWith:oldInstVars]) ifTrue:[
-
"/ only new inst variable(s) has/have been added -
"/ old methods still work (the existing inst-indices are still valid)
@@ -1082,12 +1089,14 @@
"merge in class variables"
changeSet1 do:[:nm | addedNames add:nm].
-"/ Smalltalk silentLoading ifFalse:[
-"/ Transcript showCR:'recompiling instance methods accessing ' , addedNames printString , '... [added instvars]'.
-"/ Transcript endEntry.
-"/ ].
-
- newClass recompileMethodsAccessingAny:addedNames.
+ (addedNames contains:[:eachAddedName| (Smalltalk at:eachAddedName asSymbol) notNil
+ or:[(oldClass whichClassDefinesClassVar:eachAddedName) notNil]]) ifTrue:[
+"/ Smalltalk silentLoading ifFalse:[
+"/ Transcript showCR:'recompiling instance methods accessing ' , addedNames printString , '... [added instvars]'.
+"/ Transcript endEntry.
+"/ ].
+ newClass recompileMethodsAccessingAny:addedNames.
+ ].
] ifFalse:[
"/ the changeset consists of instance variables,
@@ -1164,7 +1173,7 @@
oldClass setPackage:newClass package.
].
- ((oldClassVars = newClassVars)
+ ((oldClassVars sameContentsAs: newClassVars)
and:[oldPoolVars = newPoolVars]) ifTrue:[
"/ really no change (just comment and/or category)
@@ -1284,7 +1293,7 @@
changed ifTrue:[
(superClassChange
and:[(oldSuperClass isNil or:[newSuperClass notNil and:[oldSuperClass name = newSuperClass name]])
- and:[(oldClassVars = newClassVars)
+ and:[(oldClassVars sameContentsAs: newClassVars)
and:[(oldInstVars = newInstVars)
and:[poolChange not
and:[oldClass comment = newClass comment]]]]]) ifFalse:[
@@ -1559,15 +1568,20 @@
"Created: / 30-10-2011 / 12:04:56 / cg"
!
-rebuildForChangedInstanceVariables
- "changing / adding class-inst vars -
+rebuildForChangedClassInstanceVariables
+ "only called for metaclasses.
+ changing / adding class-inst vars -
this actually creates a new metaclass and class, leaving the original
classes around as obsolete classes. This may also be true for all subclasses,
if class instance variables are added/removed.
- Existing instances continue to be defined by their original classes.
- Time will show, if this is an acceptable behavior or if we should migrate
- instances to become insts. of the new classes."
+ Existing instances become an instance of the new class
+ (which can be done without become, by changing their class only, because
+ the instance-layout has not changed).
+
+ However, if the old class is referenced somewhere (in a collection),
+ that reference will still point to the old, now obsolete class.
+ Time will show, if that is a problem and will be fixed."
|newClass newMetaclass nClassInstVars oldClass
allSubclasses oldVars
@@ -1714,28 +1728,16 @@
offset := 0. newOffsets := Dictionary new.
newNames do:[:nm | offset := offset + 1. newOffsets at:nm put:offset].
- oldOffsets associationsDo:[:a |
- |k|
-
- k := a key.
- (newOffsets includesKey:k) ifFalse:[
- changeSet add:k
- ] ifTrue:[
- (a value ~~ (newOffsets at:k)) ifTrue:[
- changeSet add:k
- ]
+ oldOffsets keysAndValuesDo:[:varName :oldOffset |
+ ((newOffsets includesKey:varName) not
+ or:[ oldOffset ~~ (newOffsets at:varName) ]) ifTrue:[
+ changeSet add:varName
]
].
- newOffsets associationsDo:[:a |
- |k|
-
- k := a key.
- (oldOffsets includesKey:k) ifFalse:[
- changeSet add:k
- ] ifTrue:[
- (a value ~~ (oldOffsets at:k)) ifTrue:[
- changeSet add:k
- ]
+ newOffsets keysAndValuesDo:[:varName :newOffset |
+ ((oldOffsets includesKey:varName) not
+ or:[ newOffset ~~ (oldOffsets at:varName) ]) ifTrue:[
+ changeSet add:varName
]
].
@@ -1920,8 +1922,9 @@
oldClass privateClassesDo:[:aClass |
aClass class setOwningClass:newClass
].
-
].
+ "/ change the instances
+ oldClass allInstancesDo:[:inst | inst changeClassTo: newClass].
ObjectMemory flushCachesFor:oldClass.
allSubclasses do:[:oldSubClass |
@@ -1941,6 +1944,9 @@
oldSubClass privateClassesDo:[:aClass |
aClass class setOwningClass:newSubClass
].
+
+ "/ change the instances
+ oldSubClass allInstancesDo:[:inst | inst changeClassTo: newSubClass].
].
"tell dependents ..."
@@ -1956,8 +1962,8 @@
oldMetaClass nameSpace ~~ Smalltalk ifTrue:[
Smalltalk changed:#classDefinition with:oldMetaClass.
].
+ oldClass setCategory:#'* obsolete *'.
- oldClass setCategory:#'* obsolete *'.
^ newMetaclass
"Created: / 29-10-1995 / 19:57:08 / cg"
@@ -2100,7 +2106,7 @@
or:[className size == 0]) ifTrue:[
ClassBuildError raiseErrorString:'invalid class name (must be a nonEmpty symbol)'.
].
- (className first isLetter or:[className first = $_]) ifFalse:[
+ (className first isLetterOrUnderline) ifFalse:[
ClassBuildError raiseErrorString:'invalid class name (must start with a letter)'.
].
@@ -2132,11 +2138,17 @@
answ := Class classConventionViolationConfirmationQuerySignal query.
answ notNil ifTrue:[^ answ].
- (self confirm:('%1 name "%2" should start with an uppercase letter\(by convention only)\\install anyway ?'
- bindWith:what with:className) withCRs)
- ifFalse:[
- ^ false
- ]
+ ClassBuildWarning new
+ className:className;
+ messageText:('%1: name "%2"\should start with an uppercase letter (by convention only)'withCRs
+ bindWith:className
+ with:(names at:idx) allBold);
+ raiseRequest.
+"/ (self confirm:('%1 name "%2" should start with an uppercase letter\(by convention only)\\install anyway ?'
+"/ bindWith:what with:className) withCRs)
+"/ ifFalse:[
+"/ ^ false
+"/ ]
].
names := instVarNameString asCollectionOfWords.
@@ -2146,13 +2158,19 @@
answ := Class classConventionViolationConfirmationQuerySignal query.
answ notNil ifTrue:[^ answ].
- (self confirm:className , ': instance variable named ''' , (names at:idx) allBold , '''
-should start with a lowercase letter (by convention only).
-
-Install anyway ?' withCRs)
- ifFalse:[
- ^ false
- ]
+ ClassBuildWarning new
+ className:className;
+ messageText:('%1: instance variable named "%2"\should start with a lowercase letter (by convention only)'withCRs
+ bindWith:className
+ with:(names at:idx) allBold);
+ raiseRequest.
+"/ (self confirm:className , ': instance variable named ''' , (names at:idx) allBold , '''
+"/should start with a lowercase letter (by convention only).
+"/
+"/Install anyway ?' withCRs)
+"/ ifFalse:[
+"/ ^ false
+"/ ]
].
names := classVarNameString asCollectionOfWords.
@@ -2162,13 +2180,19 @@
answ := Class classConventionViolationConfirmationQuerySignal query.
answ notNil ifTrue:[^ answ].
- (self confirm:className , ': class variable named ''' , (names at:idx) allBold , '''
-should start with an uppercase letter (by convention only).
-
-Install anyway ?' withCRs)
- ifFalse:[
- ^ false
- ].
+ ClassBuildWarning new
+ className:className;
+ messageText:('%1: class variable named "%2"\should start with an uppercase letter (by convention only)'withCRs
+ bindWith:className
+ with:(names at:idx) allBold);
+ raiseRequest.
+"/ (self confirm:className , ': class variable named ''' , (names at:idx) allBold , '''
+"/should start with an uppercase letter (by convention only).
+"/
+"/Install anyway ?' withCRs)
+"/ ifFalse:[
+"/ ^ false
+"/ ].
].
^ true
@@ -2372,11 +2396,11 @@
!ClassBuilder class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libbasic/ClassBuilder.st,v 1.127 2014-01-23 16:11:41 stefan Exp $'
+ ^ '$Header: /cvs/stx/stx/libbasic/ClassBuilder.st,v 1.136 2015-03-27 10:41:00 stefan Exp $'
!
version_CVS
- ^ '$Header: /cvs/stx/stx/libbasic/ClassBuilder.st,v 1.127 2014-01-23 16:11:41 stefan Exp $'
+ ^ '$Header: /cvs/stx/stx/libbasic/ClassBuilder.st,v 1.136 2015-03-27 10:41:00 stefan Exp $'
! !