Christoph Thiede uploaded a new version of Kernel to project The Trunk: http://source.squeak.org/trunk/Kernel-ct.1555.mcz
==================== Summary ====================
Name: Kernel-ct.1555 Author: ct Time: 25 February 2024, 7:56:23.908593 pm UUID: 45f6b27d-e825-c34b-a540-5c173c78c951 Ancestors: Kernel-ct.1554, Kernel-ct.1356, Kernel-ct.1408, Kernel-ct.1450, Kernel-ct.1455
Merge commit.
Kernel-ct.1301: Documents the small but essential difference between #sendTo: and #sentTo:.
Kernel-ct.1356: Fixes and refactors ClassBuilder cleanupAndCheckClassHierarchy which was broken due to a missing #informUserDuring: implementation. Also adds progress bars during the operation.
Kernel-ct.1408: Proposal: Show nested exception in the description of BrokenPromise. Revision: Honor the fact that Promise errors are not necessarily exceptions. Reuse #messageText rather than overriding #description.
Kernel-ct.1450: Updates comment in TimedOut.
Kernel-ct.1455: Adds basic support for #acceptsLoggingOfCompilation to class comments by allowing strings in BasicClassOrganizer classComment.
=============== Diff against Kernel-ct.1554 ===============
Item was changed: ----- Method: BasicClassOrganizer>>classComment (in category 'accessing') ----- classComment classComment ifNil: [^ '']. + (classComment isString + or: [classComment isText]) + ifTrue: [^ classComment]. + ^ classComment text + ifNil: ['']! - ^ classComment text ifNil: ['']!
Item was changed: ----- Method: BasicClassOrganizer>>classComment:stamp: (in category 'accessing') ----- classComment: aString stamp: aStamp + "Store the comment, aString, associated with the object that refers to the receiver. PRIVATE!! Clients should use aClass classComment: instead." - "Store the comment, aString, associated with the object that refers to the receiver."
self commentStamp: aStamp. (aString isKindOf: RemoteString) ifTrue: [classComment := aString] ifFalse: [(aString == nil or: [aString size = 0]) ifTrue: [classComment := nil] ifFalse: + [classComment := aString]] - [self error: 'use aClass classComment:'. - classComment := RemoteString newString: aString onFileNumber: 2]] "Later add priorSource and date and initials?"!
Item was changed: ----- Method: BasicClassOrganizer>>commentRemoteStr (in category 'accessing') ----- commentRemoteStr + ^ (classComment isKindOf: RemoteString) + ifTrue: [classComment]! - ^ classComment!
Item was changed: ----- Method: BasicClassOrganizer>>fileOutCommentOn:moveSource:toFile: (in category 'fileIn/Out') ----- fileOutCommentOn: aFileStream moveSource: moveSource toFile: fileIndex "Copy the class comment to aFileStream. If moveSource is true (as in compressChanges or compressSources, then update classComment to point to the new file." | fileComment | + self hasNoComment ifTrue: [^ self]. + + aFileStream cr. + fileComment := RemoteString + newString: self classComment + onFileNumber: fileIndex + toFile: aFileStream. + moveSource ifTrue: [classComment := fileComment].! - classComment ifNotNil: - [aFileStream cr. - fileComment := RemoteString newString: classComment text - onFileNumber: fileIndex toFile: aFileStream. - moveSource ifTrue: [classComment := fileComment]]!
Item was changed: ----- Method: BasicClassOrganizer>>moveChangedCommentToFile:numbered: (in category 'fileIn/Out') ----- moveChangedCommentToFile: aFileStream numbered: fileIndex "If the comment is in the changes file, then move it to a new file."
+ (self commentRemoteStr ~~ nil and: [classComment sourceFileNumber > 1]) ifTrue: - (classComment ~~ nil and: [classComment sourceFileNumber > 1]) ifTrue: [self fileOutCommentOn: aFileStream moveSource: true toFile: fileIndex]!
Item was added: + ----- Method: BrokenPromise>>error (in category 'accessing') ----- + error + + ^ promise ifNotNil: [promise error]!
Item was added: + ----- Method: BrokenPromise>>messageText (in category 'accessing') ----- + messageText + + ^ messageText ifNil: + [self error ifNotNil: [:error | + error asString]]!
Item was changed: ----- Method: ClassBuilder class>>checkClassHierarchyConsistency (in category 'cleanup obsolete classes') ----- checkClassHierarchyConsistency "Check the consistency of the class hierarchy. The class hierarchy is consistent if the following two logical equivalences hold for classes A and B: - B is obsolete and 'B superclass' yields A <--> 'A obsoleteSubclasses' contains B - B is not obsolete and 'B superclass' yields A <--> 'A subclasses' contains B" + + Transcript cr; show: 'Start checking the class hierarchy...'. + Smalltalk garbageCollect. + + Metaclass allInstances + do: [:meta | + meta allInstances do: [:each | self checkClassHierarchyConsistencyFor: each]. + self checkClassHierarchyConsistencyFor: meta] + displayingProgress: 'Validating class hierarchy' translated. + + Transcript show: 'OK'.! - self informUserDuring:[:bar| - self checkClassHierarchyConsistency: bar. - ].!
Item was removed: - ----- Method: ClassBuilder class>>checkClassHierarchyConsistency: (in category 'cleanup obsolete classes') ----- - checkClassHierarchyConsistency: informer - "Check the consistency of the class hierarchy. The class hierarchy is consistent if the following - two logical equivalences hold for classes A and B: - - B is obsolete and 'B superclass' yields A <--> 'A obsoleteSubclasses' contains B - - B is not obsolete and 'B superclass' yields A <--> 'A subclasses' contains B" - | classes | - Transcript cr; show: 'Start checking the class hierarchy...'. - Smalltalk garbageCollect. - classes := Metaclass allInstances. - classes keysAndValuesDo: [:index :meta | - informer value:'Validating class hierarchy ', (index * 100 // classes size) printString,'%'. - meta allInstances do: [:each | self checkClassHierarchyConsistencyFor: each]. - self checkClassHierarchyConsistencyFor: meta. - ]. - Transcript show: 'OK'.!
Item was changed: ----- Method: ClassBuilder class>>cleanupAndCheckClassHierarchy (in category 'cleanup obsolete classes') ----- cleanupAndCheckClassHierarchy "Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary. Afterwards it checks whether the hierarchy is really consistent." + + Project uiManager informUser: 'Cleaning up class hierarchy...' translated during: [ + Transcript cr; show: '*** Before cleaning up ***'. + self countReallyObsoleteClassesAndMetaclasses. + self cleanupClassHierarchy. + self checkClassHierarchyConsistency. + Transcript cr; cr; show: '*** After cleaning up ***'. + self countReallyObsoleteClassesAndMetaclasses].! - self informUserDuring:[:bar| - self cleanupAndCheckClassHierarchy: bar. - ]. - !
Item was removed: - ----- Method: ClassBuilder class>>cleanupAndCheckClassHierarchy: (in category 'cleanup obsolete classes') ----- - cleanupAndCheckClassHierarchy: informer - "Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary. - Afterwards it checks whether the hierarchy is really consistent." - - Transcript cr; show: '*** Before cleaning up ***'. - self countReallyObsoleteClassesAndMetaclasses. - self cleanupClassHierarchy: informer. - self checkClassHierarchyConsistency: informer. - Transcript cr; cr; show: '*** After cleaning up ***'. - self countReallyObsoleteClassesAndMetaclasses.!
Item was changed: ----- Method: ClassBuilder class>>cleanupClassHierarchy (in category 'cleanup obsolete classes') ----- cleanupClassHierarchy "Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary." + + Transcript cr; show: 'Start fixing the class hierarchy and cleaning up...'. + Smalltalk garbageCollect. + + Metaclass allInstances + do: [:meta | + "Check classes before metaclasses (because Metaclass>>isObsolete checks whether the related class is obsolete)" + meta allInstances do: [:each | self cleanupClassHierarchyFor: each]. + self cleanupClassHierarchyFor: meta] + displayingProgress: 'Fixing class hierarchy' translated. + + Transcript show: 'DONE'.! - self informUserDuring:[:bar| - self cleanupClassHierarchy: bar. - ].!
Item was removed: - ----- Method: ClassBuilder class>>cleanupClassHierarchy: (in category 'cleanup obsolete classes') ----- - cleanupClassHierarchy: informer - "Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary." - | classes | - Transcript cr; show: 'Start fixing the class hierarchy and cleaning up...'. - Smalltalk garbageCollect. - classes := Metaclass allInstances. - classes keysAndValuesDo: [:index :meta | - informer value:'Fixing class hierarchy ', (index * 100 // classes size) printString,'%'. - "Check classes before metaclasses (because Metaclass>>isObsolete - checks whether the related class is obsolete)" - meta allInstances do: [:each | self cleanupClassHierarchyFor: each]. - self cleanupClassHierarchyFor: meta. - ]. - Transcript show: 'DONE'.!
Item was changed: ----- Method: ClassDescription>>classComment:stamp: (in category 'fileIn/Out') ----- classComment: aString stamp: aStamp "Store the comment, aString or Text or RemoteString, associated with the class we are organizing. Empty string gets stored only if had a non-empty one before."
- | ptr header file oldCommentRemoteStr | (aString isKindOf: RemoteString) ifTrue: [SystemChangeNotifier uniqueInstance classCommented: self. ^ self organization classComment: aString stamp: aStamp].
+ self acceptsLoggingOfCompilation + ifTrue: + [| ptr header file oldCommentRemoteStr | + oldCommentRemoteStr := self organization commentRemoteStr. + (aString size = 0) & (oldCommentRemoteStr == nil) ifTrue: + ["never had a class comment, no need to write empty string out" + ^ self organization classComment: nil]. + + ptr := oldCommentRemoteStr ifNil: [0] ifNotNil: [oldCommentRemoteStr sourcePointer]. + SourceFiles ifNotNil: [(file := SourceFiles at: 2) ifNotNil: + [file setToEnd; cr; nextPut: $!!. "directly" + "Should be saying (file command: ''H3'') for HTML, but ignoring it here" + header := String streamContents: [:strm | strm nextPutAll: self name; + nextPutAll: ' commentStamp: '. + aStamp storeOn: strm. + strm nextPutAll: ' prior: '; nextPutAll: ptr printString]. + file nextChunkPut: header]]. + self organization classComment: (RemoteString newString: aString onFileNumber: 2) stamp: aStamp. + file ifNotNil: [ InMidstOfFileinNotification signal ifFalse: [ file flush ] ]] + ifFalse: + [self organization classComment: aString stamp: aStamp]. + + SystemChangeNotifier uniqueInstance classCommented: self.! - oldCommentRemoteStr := self organization commentRemoteStr. - (aString size = 0) & (oldCommentRemoteStr == nil) ifTrue: [^ self organization classComment: nil]. - "never had a class comment, no need to write empty string out" - - ptr := oldCommentRemoteStr ifNil: [0] ifNotNil: [oldCommentRemoteStr sourcePointer]. - SourceFiles ifNotNil: [(file := SourceFiles at: 2) ifNotNil: - [file setToEnd; cr; nextPut: $!!. "directly" - "Should be saying (file command: 'H3') for HTML, but ignoring it here" - header := String streamContents: [:strm | strm nextPutAll: self name; - nextPutAll: ' commentStamp: '. - aStamp storeOn: strm. - strm nextPutAll: ' prior: '; nextPutAll: ptr printString]. - file nextChunkPut: header]]. - self organization classComment: (RemoteString newString: aString onFileNumber: 2) stamp: aStamp. - file ifNotNil: [ InMidstOfFileinNotification signal ifFalse: [ file flush ] ]. - SystemChangeNotifier uniqueInstance classCommented: self. - !
Item was changed: ----- Method: Message>>sendTo: (in category 'sending') ----- + sendTo: receiverObject + "Answer the result of sending this message to receiverObject" - sendTo: receiver - "answer the result of sending this message to receiver"
+ ^ receiverObject perform: selector withArguments: args! - ^ receiver perform: selector withArguments: args!
Item was changed: ----- Method: Message>>sentTo: (in category 'sending') ----- + sentTo: receiverObject + "Answer the result of sending this message to receiver. Kind of private!! To send the message to a different receiver (for example, via #doesNotUnderstand:), use #sendTo: instead." - sentTo: receiver - "answer the result of sending this message to receiver"
+ ^ lookupClass == nil + ifTrue: [receiverObject perform: selector withArguments: args] + ifFalse: [receiverObject perform: selector withArguments: args inSuperclass: lookupClass]! - lookupClass == nil - ifTrue: [^ receiver perform: selector withArguments: args] - ifFalse: [^ receiver perform: selector withArguments: args inSuperclass: lookupClass]!
Item was changed: Notification subclass: #TimedOut instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Exceptions'!
+ !TimedOut commentStamp: 'ct 3/25/2022 00:01' prior: 0! + I am signalled by BlockClosure>>#valueWithin:onTimeout: if the receiving block takes too long to execute. - !TimedOut commentStamp: 'brp 10/21/2004 17:47' prior: 0! - I am signalled by #duration:timeoutDo: if the receiving block takes too long to execute.
- I am signalled by a watchdog process spawned by #duration:timeoutDo: and caught in the same method. - I am not intended to be used elsewhere.!
packages@lists.squeakfoundation.org