hg/stx-libbasic: comparison Class.st

equal deleted inserted replaced

-:a66572e855b6
+:22f4c4bcc93f
 "
 COPYRIGHT (c) 1989 by Claus Gittinger
-All Rights Reserved
+	       All Rights Reserved
 This software is furnished under a license and may be used
 only in accordance with the terms of that license and with the
 inclusion of the above copyright notice.   This software may not
 be provided or otherwise made available to, or used by, any
 hereby transferred.
 "
 ClassDescription subclass:#Class
 instanceVariableNames:'classvars comment subclasses classFileName package'
-classVariableNames:'UpdatingChanges'
+classVariableNames:'UpdatingChanges FileOutErrorSignal'
 poolDictionaries:''
 category:'Kernel-Classes'
 !
 Class comment:'
 COPYRIGHT (c) 1989 by Claus Gittinger
-All Rights Reserved
+	      All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Class.st,v 1.18 1994-08-23 23:07:34 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Class.st,v 1.19 1994-09-29 20:38:11 claus Exp $
 '!
 !Class class methodsFor:'documentation'!
 copyright
 "
 COPYRIGHT (c) 1989 by Claus Gittinger
-All Rights Reserved
+	       All Rights Reserved
 This software is furnished under a license and may be used
 only in accordance with the terms of that license and with the
 inclusion of the above copyright notice.   This software may not
 be provided or otherwise made available to, or used by, any
 "
 !
 version
 "
-$Header: /cvs/stx/stx/libbasic/Class.st,v 1.18 1994-08-23 23:07:34 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Class.st,v 1.19 1994-09-29 20:38:11 claus Exp $
 "
 !
 documentation
 "
 Behavior - to excludes all name, source info etc.,
 however, normally all classes are subclasses of Class.
 Instance variables:
-classvars       <String>        the names of the class variables
+	classvars       <String>        the names of the class variables
-comment         <String>        the classes comment
+	comment         <String>        the classes comment
-subclasses      <Collection>    cached collection of subclasses
+	subclasses      <Collection>    cached collection of subclasses
-(currently unused - but will be soon)
+					(currently unused - but will be soon)
-classFileName   <String>        the file (or nil) where the classes
+	classFileName   <String>        the file (or nil) where the classes
-sources are found (currently not used)
+					sources are found (currently not used)
-package         <Symbol>        the package, in which the class was defined
+	package         <Symbol>        the package, in which the class was defined
 Class variables:
-UpdatingChanges <Boolean>       true if the changes-file shall be updated
+	UpdatingChanges <Boolean>       true if the changes-file shall be updated
-(except during startup and when filing in, this flag
+					(except during startup and when filing in, this flag
-is usually true)
+					 is usually true)
 WARNING: layout known by compiler and runtime system
 "
 ! !
 "the classvariable 'UpdatingChanges' controls if changes are put
 into the changes-file; normally this variable is set to true, but
 (for example) during fileIn or when changes are applied, it is set to false
 to avoid putting too much junk into the changes-file."
-UpdatingChanges := true
+UpdatingChanges := true.
+FileOutErrorSignal isNil ifTrue:[
+	Object initialize.
+	FileOutErrorSignal := Object errorSignal newSignalMayProceed:false.
+	FileOutErrorSignal nameClass:self message:#fileOutErrorSignal.
+	FileOutErrorSignal notifierString:'error during fileOut'.
+]
+! !
+!Class class methodsFor:'signal access'!
+fileOutErrorSignal
+^ FileOutErrorSignal
 ! !
 !Class class methodsFor:'creating new classes'!
 new
 |newClass|
 newClass := super new.
 newClass setComment:(self comment)
-category:(self category).
+	       category:(self category).
 ^ newClass
 ! !
 !Class methodsFor:'subclass creation'!
 subclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s category:cat
 "create a new class as a subclass of an existing class (the receiver).
 The subclass will have indexed variables if the receiving-class has."
 self isVariable ifFalse:[
-^ self class
+	^ self class
-name:t
+	    name:t
-inEnvironment:Smalltalk
+	    inEnvironment:Smalltalk
-subclassOf:self
+	    subclassOf:self
-instanceVariableNames:f
+	    instanceVariableNames:f
-variable:false
+	    variable:false
-words:true
+	    words:true
-pointers:true
+	    pointers:true
-classVariableNames:d
+	    classVariableNames:d
-poolDictionaries:s
+	    poolDictionaries:s
-category:cat
+	    category:cat
-comment:nil
+	    comment:nil
-changed:false
+	    changed:false
 ].
 self isBytes ifTrue:[
-^ self
+	^ self
-variableByteSubclass:t
+	    variableByteSubclass:t
-instanceVariableNames:f
+	    instanceVariableNames:f
-classVariableNames:d
+	    classVariableNames:d
-poolDictionaries:s
+	    poolDictionaries:s
-category:cat
+	    category:cat
 ].
 self isLongs ifTrue:[
-^ self
+	^ self
-variableLongSubclass:t
+	    variableLongSubclass:t
-instanceVariableNames:f
+	    instanceVariableNames:f
-classVariableNames:d
+	    classVariableNames:d
-poolDictionaries:s
+	    poolDictionaries:s
-category:cat
+	    category:cat
 ].
 self isFloats ifTrue:[
-^ self
+	^ self
-variableFloatSubclass:t
+	    variableFloatSubclass:t
-instanceVariableNames:f
+	    instanceVariableNames:f
-classVariableNames:d
+	    classVariableNames:d
-poolDictionaries:s
+	    poolDictionaries:s
-category:cat
+	    category:cat
 ].
 self isDoubles ifTrue:[
-^ self
+	^ self
-variableDoubleSubclass:t
+	    variableDoubleSubclass:t
-instanceVariableNames:f
+	    instanceVariableNames:f
-classVariableNames:d
+	    classVariableNames:d
-poolDictionaries:s
+	    poolDictionaries:s
-category:cat
+	    category:cat
 ].
 self isWords ifTrue:[
-^ self
+	^ self
-variableWordSubclass:t
+	    variableWordSubclass:t
-instanceVariableNames:f
+	    instanceVariableNames:f
-classVariableNames:d
+	    classVariableNames:d
-poolDictionaries:s
+	    poolDictionaries:s
-category:cat
+	    category:cat
 ].
 ^ self
-variableSubclass:t
+	variableSubclass:t
-instanceVariableNames:f
+	instanceVariableNames:f
-classVariableNames:d
+	classVariableNames:d
-poolDictionaries:s
+	poolDictionaries:s
-category:cat
+	category:cat
 !
 variableSubclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s category:cat
 "create a new class as a subclass of an existing class (the receiver)
 in which the subclass has indexable pointer variables"
 self isVariable ifTrue:[
-self isPointers ifFalse:[
+	self isPointers ifFalse:[
-^ self error:
+	    ^ self error:
-'cannot make a variable pointer subclass of a variable non-pointer class'
+		'cannot make a variable pointer subclass of a variable non-pointer class'
-]
+	]
 ].
 ^ self class
-name:t
+	name:t
-inEnvironment:Smalltalk
+	inEnvironment:Smalltalk
-subclassOf:self
+	subclassOf:self
-instanceVariableNames:f
+	instanceVariableNames:f
-variable:true
+	variable:true
-words:false
+	words:false
-pointers:true
+	pointers:true
-classVariableNames:d
+	classVariableNames:d
-poolDictionaries:s
+	poolDictionaries:s
-category:cat
+	category:cat
-comment:nil
+	comment:nil
-changed:false
+	changed:false
 !
 variableByteSubclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s category:cat
 "create a new class as a subclass of an existing class (the receiver)
 in which the subclass has indexable byte-sized nonpointer variables"
 self isVariable ifTrue:[
-self isBytes ifFalse:[
+	self isBytes ifFalse:[
-^ self error:
+	    ^ self error:
-'cannot make a variable byte subclass of a variable non-byte class'
+		'cannot make a variable byte subclass of a variable non-byte class'
-].
+	].
 ].
 ^ self class
-name:t
+	name:t
-inEnvironment:Smalltalk
+	inEnvironment:Smalltalk
-subclassOf:self
+	subclassOf:self
-instanceVariableNames:f
+	instanceVariableNames:f
-variable:true
+	variable:true
-words:false
+	words:false
-pointers:false
+	pointers:false
-classVariableNames:d
+	classVariableNames:d
-poolDictionaries:s
+	poolDictionaries:s
-category:cat
+	category:cat
-comment:nil
+	comment:nil
-changed:false
+	changed:false
 !
 variableWordSubclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s category:cat
 "create a new class as a subclass of an existing class (the receiver)
 in which the subclass has indexable word-sized nonpointer variables"
 self isVariable ifTrue:[
-self isWords ifFalse:[
+	self isWords ifFalse:[
-^ self error:
+	    ^ self error:
-'cannot make a variable word subclass of a variable non-word class'
+		'cannot make a variable word subclass of a variable non-word class'
-].
+	].
 ].
 ^ self class
-name:t
+	name:t
-inEnvironment:Smalltalk
+	inEnvironment:Smalltalk
-subclassOf:self
+	subclassOf:self
-instanceVariableNames:f
+	instanceVariableNames:f
-variable:true
+	variable:true
-words:true
+	words:true
-pointers:false
+	pointers:false
-classVariableNames:d
+	classVariableNames:d
-poolDictionaries:s
+	poolDictionaries:s
-category:cat
+	category:cat
-comment:nil
+	comment:nil
-changed:false
+	changed:false
 !
 variableLongSubclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s category:cat
 "create a new class as a subclass of an existing class (the receiver)
 in which the subclass has indexable long-sized nonpointer variables"
 self isVariable ifTrue:[
-self isLongs ifFalse:[
+	self isLongs ifFalse:[
-^ self error:
+	    ^ self error:
-'cannot make a variable long subclass of a variable non-long class'
+		'cannot make a variable long subclass of a variable non-long class'
-].
+	].
 ].
 ^ self class
-name:t
+	name:t
-inEnvironment:Smalltalk
+	inEnvironment:Smalltalk
-subclassOf:self
+	subclassOf:self
-instanceVariableNames:f
+	instanceVariableNames:f
-variable:#long
+	variable:#long
-words:false
+	words:false
-pointers:false
+	pointers:false
-classVariableNames:d
+	classVariableNames:d
-poolDictionaries:s
+	poolDictionaries:s
-category:cat
+	category:cat
-comment:nil
+	comment:nil
-changed:false
+	changed:false
 !
 variableFloatSubclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s category:cat
 "create a new class as a subclass of an existing class (the receiver)
 in which the subclass has indexable float-sized nonpointer variables"
 self isVariable ifTrue:[
-self isFloats ifFalse:[
+	self isFloats ifFalse:[
-^ self error:
+	    ^ self error:
-'cannot make a variable float subclass of a variable non-float class'
+		'cannot make a variable float subclass of a variable non-float class'
-].
+	].
 ].
 ^ self class
-name:t
+	name:t
-inEnvironment:Smalltalk
+	inEnvironment:Smalltalk
-subclassOf:self
+	subclassOf:self
-instanceVariableNames:f
+	instanceVariableNames:f
-variable:#float
+	variable:#float
-words:false
+	words:false
-pointers:false
+	pointers:false
-classVariableNames:d
+	classVariableNames:d
-poolDictionaries:s
+	poolDictionaries:s
-category:cat
+	category:cat
-comment:nil
+	comment:nil
-changed:false
+	changed:false
 !
 variableDoubleSubclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s category:cat
 "create a new class as a subclass of an existing class (the receiver)
 in which the subclass has indexable double-sized nonpointer variables"
 self isVariable ifTrue:[
-self isDoubles ifFalse:[
+	self isDoubles ifFalse:[
-^ self error:
+	    ^ self error:
-'cannot make a variable double subclass of a variable non-double class'
+		'cannot make a variable double subclass of a variable non-double class'
-].
+	].
 ].
 ^ self class
-name:t
+	name:t
-inEnvironment:Smalltalk
+	inEnvironment:Smalltalk
-subclassOf:self
+	subclassOf:self
-instanceVariableNames:f
+	instanceVariableNames:f
-variable:#double
+	variable:#double
-words:false
+	words:false
-pointers:false
+	pointers:false
-classVariableNames:d
+	classVariableNames:d
-poolDictionaries:s
+	poolDictionaries:s
-category:cat
+	category:cat
-comment:nil
+	comment:nil
-changed:false
+	changed:false
 ! !
 !Class methodsFor:'ST/V subclass creation'!
 subclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s
 "this method allows fileIn of ST/V classes
 (which seem to have no category)"
 ^ self subclass:t
-instanceVariableNames:f
+	   instanceVariableNames:f
-classVariableNames:d
+	   classVariableNames:d
-poolDictionaries:s
+	   poolDictionaries:s
-category:'ST/V classes'
+	   category:'ST/V classes'
 !
 variableByteSubclass:t classVariableNames:d poolDictionaries:s
 "this method allows fileIn of ST/V variable byte classes
 (which seem to have no category and no instvars)"
 ^ self variableByteSubclass:t
-instanceVariableNames:''
+	   instanceVariableNames:''
-classVariableNames:d
+	   classVariableNames:d
-poolDictionaries:s
+	   poolDictionaries:s
-category:'ST/V classes'
+	   category:'ST/V classes'
 !
 variableSubclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s
 "this method allows fileIn of ST/V variable pointer classes
 (which seem to have no category)"
 ^ self variableSubclass:t
-instanceVariableNames:f
+	   instanceVariableNames:f
-classVariableNames:d
+	   classVariableNames:d
-poolDictionaries:s
+	   poolDictionaries:s
-category:'ST/V classes'
+	   category:'ST/V classes'
 ! !
 !Class methodsFor:'accessing'!
 classVariableString
 Only names of class variables defined in this class are in the
 returned string."
 classvars isNil ifTrue:[^ ''].
 ^ classvars
+"
+Object classVariableString
+Float classVariableString
+"
 !
 classVarNames
 "return a collection of the class variable name-strings.
 Only names of class variables defined in this class are included
 in the returned collection - use allClassVarNames, to get all known names."
 classvars isNil ifTrue:[
-^ OrderedCollection new
+	^ OrderedCollection new
 ].
 ^ classvars asCollectionOfWords
-"Object classVarNames"
+"
-"Float classVarNames"
+Object classVarNames
+Float classVarNames
+"
+!
+classVarAt:aSymbol
+"return the value of a class variable.
+Currently, this returns nil if there is no such classvar -
+this may change."
+"
+this hides the (current) implementation of classVariables
+from the outside world. Currently, classvars are stored in
+the Smalltalk dictionary with a funny name, since there are
+no classPools yet.
+"
+^ Smalltalk at:(self name , ':' , aSymbol) asSymbol
+!
+classVarAt:aSymbol put:something
+"store something in a classvariable.
+Currently this creates a global with a funny name if no such
+classVar exists - this may change."
+"
+this hides the (current) implementation of classVariables
+from the outside world. Currently, classvars are stored in
+the Smalltalk dictionary with a funny name, since there are
+no classPools yet.
+"
+Smalltalk at:(self name , ':' , aSymbol) asSymbol put:something.
 !
 allClassVarNames
 "return a collection of all the class variable name-strings
 this includes all superclass-class variables"
 ^ self addAllClassVarNamesTo:(OrderedCollection new)
-"Float allClassVarNames"
+"
+Float allClassVarNames
+"
 !
 comment
 "return the comment (aString) of the class"
 ^ comment
-!
+"
+Object comment
+"
+!
 setComment:aString
 "set the comment of the class to be the argument, aString;
 do NOT create a change record"
 comment := aString
 !
 comment:aString
 "set the comment of the class to be the argument, aString;
-create a change record"
+create a change record and notify dependents."
+|oldComment|
 comment ~= aString ifTrue:[
-comment := aString.
+	oldComment := comment.
-self addChangeRecordForClassComment:self
+	comment := aString.
+	self changed:#comment with:oldComment.
+	self addChangeRecordForClassComment:self.
 ]
 !
 classFileName
-"return the name of the file from which the class was compiled"
+"return the name of the file from which the class was compiled.
+This is currently NOT used."
 ^ classFileName
 !
 definition
 s := WriteStream on:(String new).
 self fileOutDefinitionOn:s.
 ^ s contents
-"Object definition"
+"
-"Point definition"
+Object definition
+Point definition
+"
 !
 sharedPools
 "ST/X does not (currently) support pools"
 comment := com.
 category := categoryStringOrSymbol asSymbol
 !
 setClassVariableString:aString
-"set the classes classvarnames string. This is a dangerous
+"set the classes classvarnames string.
-(low level) operation, since the classvariables are not really
+This is a dangerous (low level) operation, since the
-created."
+classvariables are not really created or updated. Also,
+NO change record is written."
 classvars := aString
 !
 classVariableString:aString
 "set the classes classvarnames string;
-initialize new class variables with nil,
+Initialize new class variables with nil, clear and remove old ones.
-clear and remove old ones. No change record is written."
+No change record is written and no classes are recompiled."
 |prevVarNames varNames|
 "ignore for metaclasses except the one"
 (self isMeta) ifTrue:[
-(self == Metaclass) ifFalse:[
+	(self == Metaclass) ifFalse:[
-^ self
+	    ^ self
-]
+	]
 ].
 (classvars = aString) ifFalse:[
-prevVarNames := self classVarNames.
+	prevVarNames := self classVarNames.
-classvars := aString.
+	classvars := aString.
-varNames := self classVarNames.
+	varNames := self classVarNames.
-"new ones get initialized to nil;
+	"new ones get initialized to nil;
-- old ones are nilled and removed from Smalltalk"
+	 - old ones are nilled and removed from Smalltalk"
-varNames do:[:aName |
+	varNames do:[:aName |
-(prevVarNames includes:aName) ifFalse:[
+	    (prevVarNames includes:aName) ifFalse:[
-"a new one"
+		"a new one"
-Smalltalk at:(self name , ':' , aName) asSymbol put:nil.
+		self classVarAt:aName put:nil.
-] ifTrue:[
+	    ] ifTrue:[
-prevVarNames remove:aName
+		prevVarNames remove:aName
-]
+	    ]
-].
+	].
-"left overs are gone"
+	"left overs are gone"
-prevVarNames do:[:aName |
+	prevVarNames do:[:aName |
-Smalltalk at:(self name , ':' , aName) asSymbol put:nil.
+	    self classVarAt:aName put:nil.
-Smalltalk removeKey:(self name , ':' , aName) asSymbol
+	    Smalltalk removeKey:(self name , ':' , aName) asSymbol.
-].
+	].
-Smalltalk changed
+	Smalltalk changed
 ]
 !
 addClassVarName:aString
-"add a class variable if not already there"
+"add a class variable if not already there and initialize it with nil.
+Also write a change record and notify dependents.
+BUG: Currently, no recompilation is done - this will change."
 (self classVarNames includes:aString) ifFalse:[
-self classVariableString:(self classVariableString , ' ' , aString)
+	self classVariableString:(self classVariableString , ' ' , aString).
+	self addChangeRecordForClass:self.
+	self changed:#definition.
+]
+!
+removeClassVarName:aString
+"remove a class variable if not already there.
+Also write a change record and notify dependents.
+BUG: Currently, no recompilation is done - this will change."
+|names newNames|
+names := self classVarNames.
+(names includes:aString) ifTrue:[
+	newNames := ''.
+	names do:[:nm | nm ~= aString ifTrue:[newNames := newNames , nm , ' ']].
+	self classVariableString:newNames withoutSpaces.
+	self addChangeRecordForClass:self.
+	self changed:#definition.
 ]
 !
 renameCategory:oldCategory to:newCategory
-"change methods categories"
+"rename a category (changes category of those methods).
+Append a change record and notifies dependents."
 |any|
 any := false.
 methodArray do:[:aMethod |
-aMethod category = oldCategory ifTrue:[
+	aMethod category = oldCategory ifTrue:[
-aMethod category:newCategory.
+	    aMethod category:newCategory.
-any := true.
+	    any := true.
-]
+	]
 ].
 any ifTrue:[
-self addChangeRecordForRenameCategory:oldCategory to:newCategory
+	self addChangeRecordForRenameCategory:oldCategory to:newCategory.
+	self changed:#methodCategory.
 ]
 ! !
 !Class methodsFor:'adding/removing'!
 addSelector:newSelector withMethod:newMethod
 "add the method given by 2nd argument under the selector given by
 1st argument to the methodDictionary.
-Append a change record to the changes file."
+Append a change record to the changes file and tell dependents."
 (super addSelector:newSelector withMethod:newMethod) ifTrue:[
-self addChangeRecordForMethod:newMethod
+	self addChangeRecordForMethod:newMethod
 ]
 !
 removeSelector:aSelector
 "remove the selector, aSelector and its associated method
 from the methodDictionary.
-Append a change record to the changes file."
+Append a change record to the changes file and tell dependents."
 (super removeSelector:aSelector) ifTrue:[
-self addChangeRecordForRemoveSelector:aSelector
+	self addChangeRecordForRemoveSelector:aSelector.
+	self changed:#methodDictionary with:aSelector.
 ]
 ! !
 !Class methodsFor:'changes management'!
 "return a Stream for the changes file"
 |aStream|
 UpdatingChanges ifTrue:[
-aStream := FileStream oldFileNamed:'changes'.
+	aStream := FileStream oldFileNamed:'changes'.
-aStream isNil ifTrue:[
+	aStream isNil ifTrue:[
-aStream := FileStream newFileNamed:'changes'.
+	    aStream := FileStream newFileNamed:'changes'.
-aStream isNil ifTrue:[
+	    aStream isNil ifTrue:[
-self error:'cannot update changes file'.
+		self error:'cannot update changes file'.
-^ nil
+		^ nil
-]
+	    ]
-].
+	].
-aStream setToEnd
+	aStream setToEnd
 ].
 ^ aStream
 !
 sourcesStream
 "return a Stream for the sources file"
 |aStream|
 UpdatingChanges ifTrue:[
-aStream := FileStream oldFileNamed:('st.sou').
+	aStream := FileStream oldFileNamed:('st.sou').
-aStream isNil ifTrue:[
+	aStream isNil ifTrue:[
-aStream := FileStream newFileNamed:'st.sou'.
+	    aStream := FileStream newFileNamed:'st.sou'.
-aStream isNil ifTrue:[
+	    aStream isNil ifTrue:[
-Transcript showCr:'cannot update sources file'.
+		Transcript showCr:'cannot update sources file'.
-^ nil
+		^ nil
-]
+	    ]
-].
+	].
-aStream setToEnd
+	aStream setToEnd
 ].
 ^ aStream
 !
 addChangeRecordForMethod:aMethod
 |aStream|
 aStream := self changesStream.
 aStream notNil ifTrue:[
-self fileOutMethod:aMethod on:aStream.
+	self fileOutMethod:aMethod on:aStream.
-aStream cr.
+	aStream cr.
-aStream close.
+	aStream close.
-"this test allows a smalltalk without Projects/ChangeSets"
+	"this test allows a smalltalk without Projects/ChangeSets"
-Project notNil ifTrue:[
+	Project notNil ifTrue:[
-Project addMethodChange:aMethod in:self
+	    Project addMethodChange:aMethod in:self
-]
+	]
 ]
 !
 addChangeRecordForRemoveSelector:aSelector
 "add a method-remove-record to the changes file"
 |aStream|
 aStream := self changesStream.
 aStream notNil ifTrue:[
-self printClassNameOn:aStream.
+	self printClassNameOn:aStream.
-aStream nextPutAll:(' removeSelector:#' , aSelector).
+	aStream nextPutAll:(' removeSelector:#' , aSelector).
-aStream nextPut:(aStream class chunkSeparator).
+	aStream nextPut:(aStream class chunkSeparator).
-aStream cr.
+	aStream cr.
-aStream close
+	aStream close
 ]
 !
 addChangeRecordForClass:aClass
 "add a class-definition-record to the changes file"
 |aStream|
 aStream := self changesStream.
 aStream notNil ifTrue:[
-aClass fileOutDefinitionOn:aStream.
+	aClass fileOutDefinitionOn:aStream.
-aStream nextPut:(aStream class chunkSeparator).
+	aStream nextPut:(aStream class chunkSeparator).
-aStream cr.
+	aStream cr.
-aStream close
+	aStream close
 ]
 !
 addChangeRecordForClassInstvars:aClass
 "add a class-instvars-record to the changes file"
 |aStream|
 aStream := self changesStream.
 aStream notNil ifTrue:[
-aClass fileOutClassInstVarDefinitionOn:aStream.
+	aClass fileOutClassInstVarDefinitionOn:aStream.
-aStream nextPut:(aStream class chunkSeparator).
+	aStream nextPut:(aStream class chunkSeparator).
-aStream cr.
+	aStream cr.
-aStream close
+	aStream close
 ]
 !
 addChangeRecordForClassComment:aClass
 "add a class-comment-record to the changes file"
 |aStream|
 aStream := self changesStream.
 aStream notNil ifTrue:[
-aClass fileOutCommentOn:aStream.
+	aClass fileOutCommentOn:aStream.
-aStream nextPut:(aStream class chunkSeparator).
+	aStream nextPut:(aStream class chunkSeparator).
-aStream cr.
+	aStream cr.
-aStream close
+	aStream close
 ]
 !
 addChangeRecordForClassRename:oldName to:newName
 "add a class-rename-record to the changes file"
 |aStream|
 aStream := self changesStream.
 aStream notNil ifTrue:[
-aStream nextPutAll:('Smalltalk renameClass:' , oldName , ' to:''' , newName , '''').
+	aStream nextPutAll:('Smalltalk renameClass:' , oldName , ' to:''' , newName , '''').
-aStream nextPut:(aStream class chunkSeparator).
+	aStream nextPut:(aStream class chunkSeparator).
-aStream cr.
+	aStream cr.
-aStream close
+	aStream close
 ]
 !
 addChangeRecordForClassRemove:oldName
 "add a class-remove-record to the changes file"
 |aStream|
 aStream := self changesStream.
 aStream notNil ifTrue:[
-aStream nextPutAll:('Smalltalk removeClass:' , oldName).
+	aStream nextPutAll:('Smalltalk removeClass:' , oldName).
-aStream nextPut:(aStream class chunkSeparator).
+	aStream nextPut:(aStream class chunkSeparator).
-aStream cr.
+	aStream cr.
-aStream close
+	aStream close
 ]
 !
 addChangeRecordForRenameCategory:oldCategory to:newCategory
 "add a category-rename record to the changes file"
 |aStream|
 aStream := self changesStream.
 aStream notNil ifTrue:[
-self printClassNameOn:aStream.
+	self printClassNameOn:aStream.
-aStream nextPutAll:(' renameCategory:' , oldCategory storeString).
+	aStream nextPutAll:(' renameCategory:' , oldCategory storeString).
-aStream nextPutAll:(' to:' , newCategory storeString).
+	aStream nextPutAll:(' to:' , newCategory storeString).
-aStream nextPut:(aStream class chunkSeparator).
+	aStream nextPut:(aStream class chunkSeparator).
-aStream cr.
+	aStream cr.
-aStream close
+	aStream close
 ]
 !
 addChangeRecordForChangeCategory
 "add a category change record to the changes file"
 |aStream|
 aStream := self changesStream.
 aStream notNil ifTrue:[
-self printClassNameOn:aStream.
+	self printClassNameOn:aStream.
-aStream nextPutAll:(' category:' , category storeString).
+	aStream nextPutAll:(' category:' , category storeString).
-aStream nextPut:(aStream class chunkSeparator).
+	aStream nextPut:(aStream class chunkSeparator).
-aStream cr.
+	aStream cr.
-aStream close
+	aStream close
 ]
 !
 addChangeRecordForSnapshot:aFileName
 "add a snapshot-record to the changes file"
 |aStream|
 aStream := self changesStream.
 aStream notNil ifTrue:[
-aStream nextPutAll:('''---- snapshot ' , aFileName , ' ',
+	aStream nextPutAll:('''---- snapshot ' , aFileName , ' ',
-Date today printString , ' ' ,
+			    Date today printString , ' ' ,
-Time now printString ,
+			    Time now printString ,
-' ----''!!').
+			    ' ----''!!').
-aStream cr.
+	aStream cr.
-aStream close
+	aStream close
 ]
 ! !
 !Class methodsFor:'compiling'!
 !
 recompileMethodsAccessingAny:setOfNames
 "recompile all methods accessing a variable from setOfNames"
+self recompileMethodsAccessingAny:setOfNames orSuper:false
+!
+recompileMethodsAccessingAny:setOfNames orSuper:superBoolean
+"recompile all methods accessing a variable from setOfNames,
+or super (if superBoolean is true)"
 |p|
 selectorArray do:[:aSelector |
-|m|
+	|m|
-m := self compiledMethodAt:aSelector.
+	m := self compiledMethodAt:aSelector.
-p := Parser parseMethod:(m source) in:self.
+	p := Parser parseMethod:(m source) in:self.
-(p isNil or:[p usedVars notNil and:[p usedVars includesAny:setOfNames]]) ifTrue:[
+	(p isNil
-self recompile:aSelector
+	 or:[(p usedVars notNil and:[p usedVars includesAny:setOfNames])
-]
+	 or:[superBoolean and:[p usesSuper]]]) ifTrue:[
+	    self recompile:aSelector
+	]
 ]
 !
 recompile:aSelector
 "recompile the method associated with the argument, aSelector;
 |cat code upd|
 upd := Class updateChanges:false.
 [
-cat := (self compiledMethodAt:aSelector) category.
+	cat := (self compiledMethodAt:aSelector) category.
-code := self sourceCodeAt:aSelector.
+	code := self sourceCodeAt:aSelector.
-self compiler compile:code forClass:self inCategory:cat
+	self compiler compile:code forClass:self inCategory:cat
 ] valueNowOrOnUnwindDo:[
-Class updateChanges:upd
+	Class updateChanges:upd
 ]
 !
 recompile
 "recompile all methods
 used when a class changes instances and therefore all methods
 have to be recompiled"
 selectorArray do:[:aSelector |
-self recompile:aSelector
+	self recompile:aSelector
 ]
 !
 recompileAll
 "recompile this class and all subclasses"
 |classes|
 classes := self subclasses.
 self recompile.
 classes do:[:aClass |
-aClass recompileAll
+	aClass recompileAll
 ]
 !
 recompileInvalidatedMethods:trap
 "recompile all invalidated methods"
 trapCode := trap code.
 trapByteCode := trap byteCode.
 selectorArray do:[:aSelector |
-|m|
+	|m|
-m := self compiledMethodAt:aSelector.
+	m := self compiledMethodAt:aSelector.
-((m code == trapCode) and:[m byteCode == trapByteCode]) ifTrue:[
+	((m code == trapCode) and:[m byteCode == trapByteCode]) ifTrue:[
-self recompile:aSelector
+	    self recompile:aSelector
-]
+	]
 ]
 ! !
 !Class methodsFor:'queries'!
 |newList cat|
 newList := OrderedCollection new.
 methodArray do:[:aMethod |
-cat := aMethod category.
+	cat := aMethod category.
-newList indexOf:cat ifAbsent:[newList add:cat]
+	newList indexOf:cat ifAbsent:[newList add:cat]
 ].
 ^ newList
 !
 allCategories
 addAllClassVarNamesTo:aCollection
 "helper - add the name-strings of the class variables and of the class-vars
 of all superclasses to the argument, aCollection. Return aCollection"
 (superclass notNil) ifTrue:[
-superclass addAllClassVarNamesTo:aCollection
+	superclass addAllClassVarNamesTo:aCollection
 ].
 classvars notNil ifTrue:[
-aCollection addAll:(classvars asCollectionOfWords).
+	aCollection addAll:(classvars asCollectionOfWords).
 ].
 ^ aCollection
 !
 addCategoriesTo:aCollection
 "helper - add categories to the argument, aCollection"
 |cat|
 methodArray do:[:aMethod |
-cat := aMethod category.
+	cat := aMethod category.
-(aCollection detect:[:element | cat = element]
+	(aCollection detect:[:element | cat = element]
-ifNone:[nil])
+		     ifNone:[nil])
-isNil ifTrue:[
+	    isNil ifTrue:[
-aCollection add:cat
+		aCollection add:cat
-]
+	]
 ].
 ^ aCollection
 !
 addAllCategoriesTo:aCollection
 "helper - add categories and all superclasses categories
 to the argument, aCollection"
 (superclass notNil) ifTrue:[
-superclass addAllCategoriesTo:aCollection
+	superclass addAllCategoriesTo:aCollection
 ].
 ^ self addCategoriesTo:aCollection
 ! !
 !Class methodsFor:'fileIn interface'!
 The c-function has the name cFunctionNameString, and expects parameters as specified in
 argTypeArray. The functions return value has a type as specified by returnType.
 Warning: this interface is EXPERIMENTAL - it may change or even be removed."
 StubGenerator createStubFor:selector calling:cFunctionNameString
-args:argTypeArray returning:returnType
+			   args:argTypeArray returning:returnType
-in:self
+			     in:self
 "
 Object subclass:#CInterface
-instanceVariableNames:''
+	    instanceVariableNames:''
-classVariableNames:''
+	    classVariableNames:''
-poolDictionaries:''
+	    poolDictionaries:''
-category:'Examples'.
+	    category:'Examples'.
 CInterface cInterfaceFunction:#printfOn:format:withFloat:
-calling:'fprintf'
+			   calling:'fprintf'
-args:#(ExternalStream String Float)
+			      args:#(ExternalStream String Float)
-returning:#SmallInteger.
+			 returning:#SmallInteger.
 CInterface printfOn:Stdout format:'this is a float: %g' withFloat:(Float pi). Stdout cr
 "
 ! !
 "append an expression on aStream, which defines my comment"
 aStream nextPutAll:name.
 aStream nextPutAll:' comment:'.
 comment isNil ifTrue:[
-aStream nextPutAll:''''''
+	aStream nextPutAll:''''''
 ] ifFalse:[
-aStream nextPutAll:(comment storeString)
+	aStream nextPutAll:(comment storeString)
 ].
 aStream cr
 !
 fileOutDefinitionOn:aStream
 "take care of nil-superclass"
 superclass isNil ifTrue:[
 "/      previous versions of stc were not able to compile nil-subclasses;
 "/      after 2.10, it can ...
 "/        line := 'Object "nil"'.
-line := 'nil'
+	line := 'nil'
 ] ifFalse:[
-line := (superclass name)
+	line := (superclass name)
 ].
 superclass isNil ifTrue:[
-isVar := self isVariable
+	isVar := self isVariable
 ] ifFalse:[
-"I cant remember what this is for ?"
+	"I cant remember what this is for ?"
-isVar := (self isVariable and:[superclass isVariable not])
+	isVar := (self isVariable and:[superclass isVariable not])
 ].
 isVar ifTrue:[
-self isBytes ifTrue:[
+	self isBytes ifTrue:[
-line := line , ' variableByteSubclass:#'
+	    line := line , ' variableByteSubclass:#'
-] ifFalse:[
+	] ifFalse:[
-self isWords ifTrue:[
+	    self isWords ifTrue:[
-line := line , ' variableWordSubclass:#'
+		line := line , ' variableWordSubclass:#'
-] ifFalse:[
+	    ] ifFalse:[
-self isLongs ifTrue:[
+		self isLongs ifTrue:[
-line := line , ' variableLongSubclass:#'
+		    line := line , ' variableLongSubclass:#'
-] ifFalse:[
+		] ifFalse:[
-self isFloats ifTrue:[
+		    self isFloats ifTrue:[
-line := line , ' variableFloatSubclass:#'
+			line := line , ' variableFloatSubclass:#'
-] ifFalse:[
+		    ] ifFalse:[
-self isDoubles ifTrue:[
+			self isDoubles ifTrue:[
-line := line , ' variableDoubleSubclass:#'
+			    line := line , ' variableDoubleSubclass:#'
-] ifFalse:[
+			] ifFalse:[
-line := line , ' variableSubclass:#'
+			    line := line , ' variableSubclass:#'
-]
+			]
-]
+		    ]
-]
+		]
-]
+	    ]
-]
+	]
 ] ifFalse:[
-line := line , ' subclass:#'
+	line := line , ' subclass:#'
 ].
 line := line , name.
 aStream nextPutAll:line.
 aStream crTab.
 aStream nextPutAll:' poolDictionaries:'''''.
 aStream crTab.
 aStream nextPutAll:' category:'.
 category isNil ifTrue:[
-aStream nextPutAll:''''''
+	aStream nextPutAll:''''''
 ] ifFalse:[
-aStream nextPutAll:(category asString storeString)
+	aStream nextPutAll:(category asString storeString)
 ].
 aStream cr
 !
 fileOutClassInstVarDefinitionOn:aStream
 !
 fileOutCategory:aCategory on:aStream
 "file out all methods belonging to aCategory, aString onto aStream"
-|nMethods count sep|
+|nMethods count sep source|
 methodArray notNil ifTrue:[
-nMethods := 0.
+	nMethods := 0.
-methodArray do:[:aMethod |
+	methodArray do:[:aMethod |
-(aCategory = aMethod category) ifTrue:[
+	    (aCategory = aMethod category) ifTrue:[
-nMethods := nMethods + 1
+		nMethods := nMethods + 1
-]
+	    ]
-].
+	].
-sep := aStream class chunkSeparator.
+	sep := aStream class chunkSeparator.
-(nMethods ~~ 0) ifTrue:[
+	(nMethods ~~ 0) ifTrue:[
-aStream nextPut:sep.
+	    aStream nextPut:sep.
-self printClassNameOn:aStream.
+	    self printClassNameOn:aStream.
-aStream nextPutAll:' methodsFor:'''.
+	    aStream nextPutAll:' methodsFor:'''.
-aCategory notNil ifTrue:[
+	    aCategory notNil ifTrue:[
-aStream nextPutAll:aCategory
+		aStream nextPutAll:aCategory
-].
+	    ].
-aStream nextPut:$'. aStream nextPut:sep. aStream cr.
+	    aStream nextPut:$'. aStream nextPut:sep. aStream cr.
-aStream cr.
+	    aStream cr.
-count := 1.
+	    count := 1.
-methodArray do:[:aMethod |
+	    methodArray do:[:aMethod |
-(aCategory = aMethod category) ifTrue:[
+		(aCategory = aMethod category) ifTrue:[
-aStream nextChunkPut:(aMethod source).
+		    source := aMethod source.
-(count ~~ nMethods) ifTrue:[
+		    source isNil ifTrue:[
-aStream cr.
+			FileOutErrorSignal raiseRequestWith:'no source for method'
-aStream cr
+		    ] ifFalse:[
-].
+			aStream nextChunkPut:(aMethod source).
-count := count + 1
+		    ].
-]
+		    (count ~~ nMethods) ifTrue:[
-].
+			aStream cr.
-aStream space.
+			aStream cr
-aStream nextPut:sep.
+		    ].
-aStream cr
+		    count := count + 1
-]
+		]
+	    ].
+	    aStream space.
+	    aStream nextPut:sep.
+	    aStream cr
+	]
 ]
 !
 fileOutMethod:aMethod on:aStream
 "file out the method, aMethod onto aStream"
-|cat sep|
+|cat sep source|
 methodArray notNil ifTrue:[
-sep := aStream class chunkSeparator.
+	sep := aStream class chunkSeparator.
-aStream nextPut:sep.
+	aStream nextPut:sep.
-self printClassNameOn:aStream.
+	self printClassNameOn:aStream.
-aStream nextPutAll:' methodsFor:'''.
+	aStream nextPutAll:' methodsFor:'''.
-cat := aMethod category.
+	cat := aMethod category.
-cat notNil ifTrue:[
+	cat notNil ifTrue:[
-aStream nextPutAll:cat
+	    aStream nextPutAll:cat
-].
+	].
-aStream nextPut:$'.
+	aStream nextPut:$'.
-aStream nextPut:sep.
+	aStream nextPut:sep.
-aStream cr.
+	aStream cr.
-aStream cr.
+	aStream cr.
-aStream nextChunkPut:(aMethod source).
+	source := aMethod source.
-aStream space.
+	source isNil ifTrue:[
-aStream nextPut:sep.
+	    FileOutErrorSignal
-aStream cr
+		raiseRequestWith:self
+		errorString:('no source for method: ' ,
+			     self name , '>>' ,
+			     (self selectorForMethod:aMethod))
+	] ifFalse:[
+	    aStream nextChunkPut:(aMethod source).
+	].
+	aStream space.
+	aStream nextPut:sep.
+	aStream cr
 ]
 !
 fileOutOn:aStream
 "file out my definition and all methods onto aStream"
 "
 if there is a copyright method, add a copyright
 at the beginning
 "
 (self class selectorArray includes:#copyright) ifTrue:[
-"
+	"
-get the copyright methods source,
+	 get the copyright methods source,
-and insert at beginning.
+	 and insert at beginning.
-"
+	"
-copyrightText := (self class compiledMethodAt:#copyright) source.
+	copyrightText := (self class compiledMethodAt:#copyright) source.
-copyrightText isNil ifTrue:[
+	copyrightText isNil ifTrue:[
-"
+	    "
-no source available - trigger an error
+	     no source available - trigger an error
-"
+	    "
-self error:'no source for class ' , name , ' available. Cannot fileOut'.
+	    self error:'no source for class ' , name , ' available. Cannot fileOut'.
-^ self
+	    ^ self
-].
+	].
-copyrightText := copyrightText asCollectionOfLines.
+	copyrightText := copyrightText asCollectionOfLines.
-copyrightText := copyrightText copyFrom:2 to:(copyrightText size).
+	copyrightText := copyrightText copyFrom:2 to:(copyrightText size).
-copyrightText do:[:line | aStream nextPutAll:line. aStream cr.].
+	copyrightText do:[:line | aStream nextPutAll:line. aStream cr.].
 ].
 sep := aStream class chunkSeparator.
 "
 first, a timestamp
 aStream cr.
 "
 optional classInstanceVariables
 "
 self class instanceVariableString isBlank ifFalse:[
-self fileOutClassInstVarDefinitionOn:aStream.
+	self fileOutClassInstVarDefinitionOn:aStream.
-aStream nextPut:sep.
+	aStream nextPut:sep.
-aStream cr.
+	aStream cr.
-aStream cr
+	aStream cr
 ].
 "
 a comment - if any
 "
 comment notNil ifTrue:[
-aStream nextPutAll:name.
+	aStream nextPutAll:name.
-aStream nextPutAll:' comment:'.
+	aStream nextPutAll:' comment:'.
-aStream nextPutAll:(comment storeString).
+	aStream nextPutAll:(comment storeString).
-aStream nextPut:sep.
+	aStream nextPut:sep.
-aStream cr.
+	aStream cr.
-aStream cr
+	aStream cr
 ].
 "
 methods from all categories in metaclass
 "
 collectionOfCategories := self class categories.
 collectionOfCategories notNil ifTrue:[
-collectionOfCategories do:[:aCategory |
+	collectionOfCategories do:[:aCategory |
-self class fileOutCategory:aCategory on:aStream.
+	    self class fileOutCategory:aCategory on:aStream.
-aStream cr
+	    aStream cr
-]
+	]
 ].
 "
 methods from all categories in myself
 "
 collectionOfCategories := self categories.
 collectionOfCategories notNil ifTrue:[
-collectionOfCategories do:[:aCategory |
+	collectionOfCategories do:[:aCategory |
-self fileOutCategory:aCategory on:aStream.
+	    self fileOutCategory:aCategory on:aStream.
-aStream cr
+	    aStream cr
-]
+	]
 ].
 "
 optionally an initialize message
 "
 (self class implements:#initialize) ifTrue:[
-aStream nextPutAll:(name , ' initialize').
+	aStream nextPutAll:(name , ' initialize').
-aStream nextPut:sep.
+	aStream nextPut:sep.
-aStream cr
+	aStream cr
 ]
 !
 fileOutCategory:aCategory
 "create a file 'class-category.st' consisting of all methods in aCategory.
 "
 this test allows a smalltalk to be built without Projects/ChangeSets
 "
 Project notNil ifTrue:[
-fileName := Project currentProjectDirectory , fileName.
+	fileName := Project currentProjectDirectory , fileName.
+].
+"
+if file exists, save original in a .sav file
+"
+fileName asFilename exists ifTrue:[
+	fileName asFilename copyTo:(fileName , '.sav')
 ].
 aStream := FileStream newFileNamed:fileName.
+aStream isNil ifTrue:[
+	^ FileOutErrorSignal raiseRequestWith:fileName
+				  errorString:('cannot create file:', fileName)
+].
 self fileOutCategory:aCategory on:aStream.
 aStream close
 !
 fileOutMethod:aMethod
 |aStream fileName selector|
 selector := self selectorForMethod:aMethod.
 selector notNil ifTrue:[
-fileName := name , '-' , selector, '.st'.
+	fileName := name , '-' , selector, '.st'.
-fileName replaceAll:$: by:$_.
+	fileName replaceAll:$: by:$_.
-"
+	"
-this test allows a smalltalk to be built without Projects/ChangeSets
+	 this test allows a smalltalk to be built without Projects/ChangeSets
-"
+	"
-Project notNil ifTrue:[
+	Project notNil ifTrue:[
-fileName := Project currentProjectDirectory , fileName.
+	    fileName := Project currentProjectDirectory , fileName.
-].
+	].
-aStream := FileStream newFileNamed:fileName.
-self fileOutMethod:aMethod on:aStream.
+	"
-aStream close
+	 if file exists, save original in a .sav file
+	"
+	fileName asFilename exists ifTrue:[
+	    fileName asFilename copyTo:(fileName , '.sav')
+	].
+	aStream := FileStream newFileNamed:fileName.
+	aStream isNil ifTrue:[
+	    ^ FileOutErrorSignal raiseRequestWith:fileName
+				      errorString:('cannot create file:', fileName)
+	].
+	self fileOutMethod:aMethod on:aStream.
+	aStream close
 ]
 !
 fileOut
 "create a file 'class.st' consisting of all methods in myself.
 If the current project is not nil, create the file in the projects
-directory."
+directory. Care is taken, to not clobber any existing file in
+case of errors (for example: disk full). Also, since the classes
-|aStream fileName|
+methods need a valid sourcefile, the current sourceFile cannot be rewritten,
+but must be kept around until the fileOut is finished."
-fileName := (Smalltalk fileNameForClass:self name) , '.st'.
+|aStream baseName dirName fileName newFileName needRename|
+baseName := (Smalltalk fileNameForClass:self name).
+fileName := baseName , '.st'.
 "
 this test allows a smalltalk to be built without Projects/ChangeSets
 "
 Project notNil ifTrue:[
-fileName := Project currentProjectDirectory , fileName.
+	dirName := Project currentProjectDirectory
-].
+] ifFalse:[
-aStream := FileStream newFileNamed:fileName.
+	dirName := ''
+].
+fileName := dirName , fileName.
+"
+if file exists, copy the existing to a .sav-file,
+create new file in a .new-file,
+and, if that worked rename afterwards ...
+"
+fileName asFilename exists ifTrue:[
+	fileName asFilename copyTo:('/tmp/' , baseName , '.sav').
+	newFileName := dirName , baseName , '.new'.
+	needRename := true
+] ifFalse:[
+	newFileName := fileName.
+	needRename := false
+].
+aStream := FileStream newFileNamed:newFileName.
 aStream isNil ifTrue:[
-^ self error:('cannot create source file:', fileName)
+	^ FileOutErrorSignal raiseRequestWith:newFileName
+				  errorString:('cannot create file:', newFileName)
 ].
 self fileOutOn:aStream.
-aStream close
+aStream close.
+"
+finally, replace the old-file
+be careful, if the old one is a symbolic link; in this case,
+we have to do a copy ...
+"
+needRename ifTrue:[
+	newFileName asFilename copyTo:fileName.
+	newFileName asFilename delete
+].
 !
 fileOutIn:aFileDirectory
 "create a file 'class.st' consisting of all methods in self in
 directory aFileDirectory (ignoring any directory setting in
 |aStream fileName|
 fileName := (Smalltalk fileNameForClass:self name) , '.st'.
 aStream := FileStream newFileNamed:fileName in:aFileDirectory.
 aStream isNil ifTrue:[
-^ self error:('cannot create source file:', fileName)
+	^ self error:('cannot create source file:', fileName)
 ].
 self fileOutOn:aStream.
 aStream close
 ! !
-!Class methodsFor:'obsolete binary fileOut'!
-XXbinaryFileOutMethodsOn:aStream
-"binary file out all methods onto aStream"
-|temporaryMethod index|
-methodArray notNil ifTrue:[
-aStream nextPut:$!!.
-self printClassNameOn:aStream.
-aStream nextPutAll:' binaryMethods'.
-aStream nextPut:$!!.
-aStream cr.
-index := 1.
-methodArray do:[:aMethod |
-(selectorArray at:index) storeOn:aStream.
-aStream nextPut:$!!.
-aMethod byteCode isNil ifTrue:[
-temporaryMethod := self compiler compile:(aMethod source)
-forClass:self
-inCategory:(aMethod category)
-notifying:nil
-install:false.
-temporaryMethod binaryFileOutOn:aStream
-] ifFalse:[
-aMethod binaryFileOutOn:aStream
-].
-aStream cr.
-index := index + 1
-].
-aStream nextPut:$!!.
-aStream cr
-]
-!
-XXbinaryFileOutOn:aStream
-"file out all methods onto aStream"
-aStream nextPut:$'.
-aStream nextPutAll:('From Smalltalk/X, Version:'
-, (Smalltalk versionString)
-, ' on ').
-aStream nextPutAll:(Date today printString , ' at ' , Time now printString).
-aStream nextPut:$'.
-aStream nextPut:$!!.
-aStream cr.
-self fileOutDefinitionOn:aStream.
-aStream nextPut:$!!.
-aStream cr.
-comment notNil ifTrue:[
-aStream nextPutAll:name.
-aStream nextPutAll:' comment:'.
-aStream nextPutAll:(comment storeString).
-aStream nextPut:$!!.
-aStream cr
-].
-self class binaryFileOutMethodsOn:aStream.
-self binaryFileOutMethodsOn:aStream.
-(self class implements:#initialize) ifTrue:[
-aStream nextPutAll:(name , ' initialize').
-aStream nextPut:$!!.
-aStream cr
-]
-!
-XXbinaryFileOut
-"create a file 'class.sb' consisting of all methods in myself.
-If the current project is not nil, create the file in the projects
-directory."
-|aStream fileName|
-fileName := (Smalltalk fileNameForClass:self name) , '.sb'.
-Project notNil ifTrue:[
-fileName := Project currentProjectDirectory , fileName.
-].
-aStream := FileStream newFileNamed:fileName.
-aStream isNil ifTrue:[
-^ self error:('cannot create class file:', fileName)
-].
-self binaryFileOutOn:aStream.
-aStream close
-! !
 !Class methodsFor:'printOut'!
 printClassNameOn:aStream
 "helper for fileOut - print my name if I am not a Metaclass;
 otherwise my name without -class followed by space-class"
 self isMeta ifTrue:[
-aStream nextPutAll:(name copyTo:(name size - 5)).
+	aStream nextPutAll:(name copyTo:(name size - 5)).
-aStream nextPutAll:' class'
+	aStream nextPutAll:' class'
 ] ifFalse:[
-name printOn:aStream
+	name printOn:aStream
 ]
 !
 printNameArray:anArray on:aStream indent:indent
 "print an array of strings separated by spaces; when the stream
 |thisName nextName arraySize lenMax pos mustBreak line spaces|
 arraySize := anArray size.
 arraySize ~~ 0 ifTrue:[
-pos := indent.
+	pos := indent.
-lenMax := aStream lineLength.
+	lenMax := aStream lineLength.
-thisName := anArray at:1.
+	thisName := anArray at:1.
-line := ''.
+	line := ''.
-1 to:arraySize do:[:index |
+	1 to:arraySize do:[:index |
-line := line , thisName.
+	    line := line , thisName.
-pos := pos + thisName size.
+	    pos := pos + thisName size.
-(index == arraySize) ifFalse:[
+	    (index == arraySize) ifFalse:[
-nextName := anArray at:(index + 1).
+		nextName := anArray at:(index + 1).
-mustBreak := false.
+		mustBreak := false.
-(lenMax > 0) ifTrue:[
+		(lenMax > 0) ifTrue:[
-((pos + nextName size) > lenMax) ifTrue:[
+		    ((pos + nextName size) > lenMax) ifTrue:[
-mustBreak := true
+			mustBreak := true
-]
+		    ]
-].
+		].
-mustBreak ifTrue:[
+		mustBreak ifTrue:[
-aStream nextPutAll:line.
+		    aStream nextPutAll:line.
-aStream cr.
+		    aStream cr.
-spaces isNil ifTrue:[
+		    spaces isNil ifTrue:[
-spaces := String new:indent
+			spaces := String new:indent
-].
+		    ].
-line := spaces.
+		    line := spaces.
-pos := indent
+		    pos := indent
-] ifFalse:[
+		] ifFalse:[
-line := line , ' '.
+		    line := line , ' '.
-pos := pos + 1
+		    pos := pos + 1
-].
+		].
-thisName := nextName
+		thisName := nextName
-]
+	    ]
-].
+	].
-aStream nextPutAll:line
+	aStream nextPutAll:line
 ]
 !
 printClassVarNamesOn:aStream indent:indent
 "print the class variable names indented and breaking at line end"
 |indent|
 indent := 0.
 (superclass notNil) ifTrue:[
-indent := (superclass printHierarchyAnswerIndentOn:aStream) + 2
+	indent := (superclass printHierarchyAnswerIndentOn:aStream) + 2
 ].
 aStream spaces:indent.
 aStream nextPutAll:name.
 aStream nextPutAll:' ('.
 self printInstVarNamesOn:aStream indent:(indent + name size + 2).
 self printInstVarNamesOn:aStream indent:(indent + name size + 2).
 aStream nextPutAll:')'.
 aStream cr.
 (self subclasses sort:[:a :b | a name < b name]) do:[:aSubclass |
-aSubclass printFullHierarchyOn:aStream indent:(indent + 2)
+	aSubclass printFullHierarchyOn:aStream indent:(indent + 2)
 ]
 "|printStream|
 printStream := Printer new.
 Object printFullHierarchyOn:printStream indent:0.
 aPrintStream normal.
 aPrintStream cr.
 aPrintStream nextPutAll:'superclass           '.
 superclass isNil ifTrue:[
-aPrintStream nextPutAll:'Object'
+	aPrintStream nextPutAll:'Object'
 ] ifFalse:[
-aPrintStream nextPutAll:(superclass name)
+	aPrintStream nextPutAll:(superclass name)
 ].
 aPrintStream cr.
 aPrintStream nextPutAll:'instance Variables   '.
 self printInstVarNamesOn:aPrintStream indent:21.
 aPrintStream nextPutAll:'class Variables      '.
 self printClassVarNamesOn:aPrintStream indent:21.
 aPrintStream cr.
 category notNil ifTrue:[
-aPrintStream nextPutAll:'category             '.
+	aPrintStream nextPutAll:'category             '.
-aPrintStream nextPutAll:(category printString).
+	aPrintStream nextPutAll:(category printString).
-aPrintStream cr
+	aPrintStream cr
 ].
 comment notNil ifTrue:[
-aPrintStream cr.
+	aPrintStream cr.
-aPrintStream nextPutAll:'comment:'.
+	aPrintStream nextPutAll:'comment:'.
-aPrintStream cr.
+	aPrintStream cr.
-aPrintStream italic.
+	aPrintStream italic.
-aPrintStream nextPutAll:comment.
+	aPrintStream nextPutAll:comment.
-aPrintStream normal.
+	aPrintStream normal.
-aPrintStream cr
+	aPrintStream cr
 ]
 !
 printOutSourceProtocol:aString on:aPrintStream
 "given the source in aString, print the methods message specification
 (text size < 1) ifTrue:[^self].
 aPrintStream bold.
 aPrintStream nextPutAll:(text at:1).
 aPrintStream cr.
 (text size >= 2) ifTrue:[
-aPrintStream italic.
+	aPrintStream italic.
-line := (text at:2).
+	line := (text at:2).
-nQuote := line occurrencesOf:(Character doubleQuote).
+	nQuote := line occurrencesOf:(Character doubleQuote).
-(nQuote == 2) ifTrue:[
+	(nQuote == 2) ifTrue:[
-aPrintStream nextPutAll:line.
+	    aPrintStream nextPutAll:line.
-aPrintStream cr
+	    aPrintStream cr
-] ifFalse:[
+	] ifFalse:[
-(nQuote == 1) ifTrue:[
+	    (nQuote == 1) ifTrue:[
-aPrintStream nextPutAll:line.
+		aPrintStream nextPutAll:line.
-aPrintStream cr.
+		aPrintStream cr.
-index := 3.
+		index := 3.
-line := text at:index.
+		line := text at:index.
-nQuote := line occurrencesOf:(Character doubleQuote).
+		nQuote := line occurrencesOf:(Character doubleQuote).
-[nQuote ~~ 1] whileTrue:[
+		[nQuote ~~ 1] whileTrue:[
-aPrintStream nextPutAll:line.
+		    aPrintStream nextPutAll:line.
-aPrintStream cr.
+		    aPrintStream cr.
-index := index + 1.
+		    index := index + 1.
-line := text at:index.
+		    line := text at:index.
-nQuote := line occurrencesOf:(Character doubleQuote)
+		    nQuote := line occurrencesOf:(Character doubleQuote)
-].
+		].
-aPrintStream nextPutAll:(text at:index).
+		aPrintStream nextPutAll:(text at:index).
-aPrintStream cr
+		aPrintStream cr
-]
+	     ]
-]
+	 ]
 ].
 aPrintStream normal
 !
 printOutSource:aString on:aPrintStream
 aPrintStream cr.
 inComment := false.
 textSize := text size.
 textIndex := 2.
 [textIndex <= textSize] whileTrue:[
-line := text at:textIndex.
+	line := text at:textIndex.
-((line occurrencesOf:Character doubleQuote) == 0) ifTrue:[
+	((line occurrencesOf:Character doubleQuote) == 0) ifTrue:[
-aPrintStream nextPutAll:line
+	    aPrintStream nextPutAll:line
-] ifFalse:[
+	] ifFalse:[
-lineSize := line size.
+	    lineSize := line size.
-lineIndex := 1.
+	    lineIndex := 1.
-[lineIndex <= lineSize] whileTrue:[
+	    [lineIndex <= lineSize] whileTrue:[
-aCharacter := line at:lineIndex.
+		aCharacter := line at:lineIndex.
-(aCharacter == Character doubleQuote) ifTrue:[
+		(aCharacter == Character doubleQuote) ifTrue:[
-inComment ifTrue:[
+		    inComment ifTrue:[
-aPrintStream normal.
+			aPrintStream normal.
-aPrintStream nextPut:aCharacter.
+			aPrintStream nextPut:aCharacter.
-inComment := false
+			inComment := false
-] ifFalse:[
+		    ] ifFalse:[
-aPrintStream nextPut:aCharacter.
+			aPrintStream nextPut:aCharacter.
-aPrintStream italic.
+			aPrintStream italic.
-inComment := true
+			inComment := true
-]
+		    ]
-] ifFalse:[
+		] ifFalse:[
-aPrintStream nextPut:aCharacter
+		    aPrintStream nextPut:aCharacter
-].
+		].
-lineIndex := lineIndex + 1
+		lineIndex := lineIndex + 1
-]
+	    ]
-].
+	].
-aPrintStream cr.
+	aPrintStream cr.
-textIndex := textIndex + 1
+	textIndex := textIndex + 1
 ]
 !
 printOutCategory:aCategory on:aPrintStream
 "print out all methods in aCategory on aPrintStream should be a PrintStream"
 |any|
 methodArray notNil ifTrue:[
-any := false.
+	any := false.
-methodArray do:[:aMethod |
+	methodArray do:[:aMethod |
-(aCategory = aMethod category) ifTrue:[
+	    (aCategory = aMethod category) ifTrue:[
-any := true
+		any := true
-]
+	    ]
-].
+	].
-any ifTrue:[
+	any ifTrue:[
-aPrintStream italic.
+	     aPrintStream italic.
-aPrintStream nextPutAll:aCategory.
+	     aPrintStream nextPutAll:aCategory.
-aPrintStream normal.
+	     aPrintStream normal.
-aPrintStream cr.
+	     aPrintStream cr.
-aPrintStream cr.
+	     aPrintStream cr.
-methodArray do:[:aMethod |
+	     methodArray do:[:aMethod |
-(aCategory = aMethod category) ifTrue:[
+		 (aCategory = aMethod category) ifTrue:[
-self printOutSource:(aMethod source) on:aPrintStream.
+		     self printOutSource:(aMethod source) on:aPrintStream.
-aPrintStream cr.
+		     aPrintStream cr.
-aPrintStream cr
+		     aPrintStream cr
-]
+		 ]
-].
+	     ].
-aPrintStream cr
+	     aPrintStream cr
-]
+	 ]
 ]
 !
 printOutOn:aPrintStream
 "print out all methods on aPrintStream which should be a printStream"
 |collectionOfCategories|
 self printOutDefinitionOn:aPrintStream.
 aPrintStream cr.
 collectionOfCategories := self class categories.
 collectionOfCategories notNil ifTrue:[
-aPrintStream nextPutAll:'class protocol'.
+	aPrintStream nextPutAll:'class protocol'.
-aPrintStream cr. aPrintStream cr.
+	aPrintStream cr. aPrintStream cr.
-collectionOfCategories do:[:aCategory |
+	collectionOfCategories do:[:aCategory |
-self class printOutCategory:aCategory on:aPrintStream
+	    self class printOutCategory:aCategory on:aPrintStream
-]
+	]
 ].
 collectionOfCategories := self categories.
 collectionOfCategories notNil ifTrue:[
-aPrintStream nextPutAll:'instance protocol'.
+	aPrintStream nextPutAll:'instance protocol'.
-aPrintStream cr. aPrintStream cr.
+	aPrintStream cr. aPrintStream cr.
-collectionOfCategories do:[:aCategory |
+	collectionOfCategories do:[:aCategory |
-self printOutCategory:aCategory on:aPrintStream
+	    self printOutCategory:aCategory on:aPrintStream
-]
+	]
 ]
 !
 printOutCategoryProtocol:aCategory on:aPrintStream
 |any|
 methodArray notNil ifTrue:[
-any := false.
+	any := false.
-methodArray do:[:aMethod |
+	methodArray do:[:aMethod |
-(aCategory = aMethod category) ifTrue:[
+	    (aCategory = aMethod category) ifTrue:[
-any := true
+		any := true
-]
+	    ]
-].
+	].
-any ifTrue:[
+	any ifTrue:[
-aPrintStream italic.
+	    aPrintStream italic.
-aPrintStream nextPutAll:aCategory.
+	    aPrintStream nextPutAll:aCategory.
-aPrintStream normal.
+	    aPrintStream normal.
-aPrintStream cr.
+	    aPrintStream cr.
-aPrintStream cr.
+	    aPrintStream cr.
-methodArray do:[:aMethod |
+	    methodArray do:[:aMethod |
-(aCategory = aMethod category) ifTrue:[
+		(aCategory = aMethod category) ifTrue:[
-self printOutSourceProtocol:(aMethod source)
+		    self printOutSourceProtocol:(aMethod source)
-on:aPrintStream.
+					     on:aPrintStream.
-aPrintStream cr.
+		    aPrintStream cr.
-aPrintStream cr
+		    aPrintStream cr
-]
+		]
-].
+	    ].
-aPrintStream cr
+	    aPrintStream cr
-]
+	]
 ]
 !
 printOutProtocolOn:aPrintStream
 |collectionOfCategories|
 self printOutDefinitionOn:aPrintStream.
 aPrintStream cr.
 collectionOfCategories := self class categories.
 collectionOfCategories notNil ifTrue:[
-aPrintStream nextPutAll:'class protocol'.
+	aPrintStream nextPutAll:'class protocol'.
-aPrintStream cr. aPrintStream cr.
+	aPrintStream cr. aPrintStream cr.
-collectionOfCategories do:[:aCategory |
+	collectionOfCategories do:[:aCategory |
-self class printOutCategoryProtocol:aCategory on:aPrintStream
+	    self class printOutCategoryProtocol:aCategory on:aPrintStream
-]
+	]
 ].
 collectionOfCategories := self categories.
 collectionOfCategories notNil ifTrue:[
-aPrintStream nextPutAll:'instance protocol'.
+	aPrintStream nextPutAll:'instance protocol'.
-aPrintStream cr. aPrintStream cr.
+	aPrintStream cr. aPrintStream cr.
-collectionOfCategories do:[:aCategory |
+	collectionOfCategories do:[:aCategory |
-self printOutCategoryProtocol:aCategory on:aPrintStream
+	    self printOutCategoryProtocol:aCategory on:aPrintStream
-]
+	]
 ]
 ! !
 !Class methodsFor: 'binary storage'!
 addGlobalsTo: globalDictionary manager: manager
 "
 classPool == nil ifFalse: [
-classPool associationsDo: [:assoc|
+	classPool associationsDo: [:assoc|
-globalDictionary at: assoc put: self
+	    globalDictionary at: assoc put: self
-]
+	]
 ]
 "
 !
 storeBinaryDefinitionOf: anAssociation on: stream manager: manager

changeset 153	22f4c4bcc93f
parent 139	19ccaf2031c8
child 155	edd7fc34e104