'From Squeak3.5 of ''11 April 2003'' [latest update: #5180] on 29 April 2003 at 8:59:31 pm'! !Utilities class methodsFor: 'identification'! browseUncommentedMethodsWithInitials: targetInitials "Browse uncommented methods whose initials (in the time-stamp, as logged to disk) match the given initials. Present them in chronological order. CAUTION: It will take several minutes for this to complete." "Time millisecondsToRun: [Utilities browseUncommentedMethodsWithInitials: 'jm']" | initials timeStamp methodReferences cm aMessageSet | methodReferences _ OrderedCollection new. self systemNavigation allBehaviorsDo: [:aClass | aClass selectors do: [:sel | cm _ aClass compiledMethodAt: sel. timeStamp _ Utilities timeStampForMethod: cm. timeStamp isEmpty ifFalse: [initials _ timeStamp substrings first. initials first isDigit ifFalse: [((initials = targetInitials) and: [(aClass firstPrecodeCommentFor: sel) isNil]) ifTrue: [methodReferences add: (MethodReference new setStandardClass: aClass methodSymbol: sel)]]]]]. aMessageSet _ MessageSet new initializeMessageList: methodReferences. aMessageSet sortByDate. MessageSet openMessageList: aMessageSet messageList name: 'Uncommented methods with initials ', targetInitials! ! !Utilities class methodsFor: 'investigations'! reportSenderCountsFor: selectorList "Produce a report on the number of senders of each of the selectors in the list. 1/27/96 sw" | total report thisSize | total _ 0. report _ ' '. selectorList do: [:selector | thisSize _ (self systemNavigation allCallsOn: selector) size. report _ report , thisSize printString , String tab , selector printString , String cr. total _ total + thisSize]. report _ report , '--- ------------------ '. report _ report , total printString , String tab , 'TOTAL '. ^ report! ! !Utilities class methodsFor: 'miscellaneous'! fixUpProblemsWithAllCategory "Moves all methods that are in formally classified a category named '-- all --' into the default 'as yet unclassified' category" "Utilities fixUpProblemsWithAllCategory" | org aCategory methodCount classCount any | self flag: #ShouldBeMovedInClassOrganization. methodCount _ 0. classCount _ 0. self systemNavigation allBehaviorsDo: [:aClass | org _ aClass organization. (org categories includes: #'-- all --') ifTrue: [any _ false. aClass selectorsDo: [:aSelector | aCategory _ org categoryOfElement: aSelector. aCategory = #'-- all --' ifTrue: [org classify: aSelector under: ClassOrganizer default suppressIfDefault: false. Transcript cr; show: aClass name, ' >> ', aSelector. methodCount _ methodCount + 1. any _ true]]. any ifTrue: [classCount _ classCount + 1]. org removeEmptyCategories]]. Transcript cr; show: methodCount printString, ' methods in ', classCount printString, ' classes moved from "-- all --" to "as yet unclassified"' ! decommissionTheAllCategory "Utilities decommissionTheAllCategory" "Moves all methods that are in a category named 'all' into the default 'as yet unclassified' category" | org aCategory methodCount classCount any | self flag: #ShouldBeMovedIntoClassOrganization. "sd" methodCount _ 0. classCount _ 0. self systemNavigation allBehaviorsDo: [:aClass | org _ aClass organization. any _ false. aClass selectorsDo: [:aSelector | aCategory _ org categoryOfElement: aSelector. aCategory = #all ifTrue: [org classify: aSelector under: ClassOrganizer default suppressIfDefault: false. methodCount _ methodCount + 1. any _ true]]. any ifTrue: [classCount _ classCount + 1]. org removeEmptyCategories]. Transcript cr; show: methodCount printString, ' methods in ', classCount printString, ' classes moved from "all" to "as yet unclassified"' ! ! !Lexicon methodsFor: 'senders'! selectorsSendingSelectedSelector "Assumes lastSendersSearchSelector is already set" | selectorSet sel cl | autoSelectString _ (self lastSendersSearchSelector upTo: $:) asString. selectorSet _ Set new. (self systemNavigation allCallsOn: self lastSendersSearchSelector) do: [:anItem | sel _ anItem methodSymbol. cl _ anItem actualClass. ((currentVocabulary includesSelector: sel forInstance: self targetObject ofClass: targetClass limitClass: limitClass) and: [targetClass includesBehavior: cl]) ifTrue: [selectorSet add: sel]]. ^ selectorSet asSortedArray! navigateToASender "Present the user with a list of senders of the currently-selected message, and navigate to the chosen one" | selectorSet chosen aSelector | aSelector _ self selectedMessageName. selectorSet _ Set new. (self systemNavigation allCallsOn: aSelector) do: [:anItem | selectorSet add: anItem methodSymbol]. selectorSet _ selectorSet select: [:sel | currentVocabulary includesSelector: sel forInstance: self targetObject ofClass: targetClass limitClass: limitClass]. selectorSet size == 0 ifTrue: [^ self beep]. self okToChange ifFalse: [^ self]. chosen _ (SelectionMenu selections: selectorSet asSortedArray) startUp. chosen isEmptyOrNil ifFalse: [self displaySelector: chosen]! setSendersSearch "Put up a list of messages sent in the current message, find all methods of the browsee which send the one the user chooses, and show that list in the message-list pane, with the 'query results' item selected in the category-list pane" | selectorSet aSelector aString | self selectedMessageName ifNil: [aString _ FillInTheBlank request: 'Type selector to search for' initialAnswer: 'flag:'. aString isEmptyOrNil ifTrue: [^ self]. Symbol hasInterned: aString ifTrue: [:sel | aSelector _ sel]] ifNotNil: [self selectMessageAndEvaluate: [:sel | aSelector _ sel]]. aSelector ifNil: [^ self]. selectorSet _ Set new. (self systemNavigation allCallsOn: aSelector) do: [:anItem | selectorSet add: anItem methodSymbol]. selectorSet _ selectorSet select: [:sel | currentVocabulary includesSelector: sel forInstance: self targetObject ofClass: targetClass limitClass: limitClass]. selectorSet size > 0 ifTrue: [currentQuery _ #senders. currentQueryParameter _ aSelector. self categoryListIndex: (categoryList indexOf: self class queryCategoryName). self messageListIndex: 0]! ! !Lexicon methodsFor: 'category list'! selectorsReferringToClassVar "Return a list of methods that refer to given class var that are in the protocol of this object" | aList aClass nonMeta poolAssoc | nonMeta _ targetClass theNonMetaClass. aClass _ nonMeta classThatDefinesClassVariable: currentQueryParameter. aList _ OrderedCollection new. poolAssoc _ aClass classPool associationAt: currentQueryParameter asSymbol. (self systemNavigation allCallsOn: poolAssoc) do: [:elem | (nonMeta isKindOf: elem actualClass) ifTrue: [aList add: elem methodSymbol]]. ^ aList! ! !ChangeSet methodsFor: 'fileIn/Out'! checkForUnsentMessages "Check the change set for unsent messages, and if any are found, open up a message-list browser on them" | nameLine allChangedSelectors augList unsent | nameLine _ '"' , self name , '"'. allChangedSelectors _ Set new. (augList _ self changedMessageListAugmented) do: [:each | each isValid ifTrue: [allChangedSelectors add: each methodSymbol]]. unsent _ self systemNavigation allUnSentMessagesIn: allChangedSelectors. unsent size = 0 ifTrue: [^ self inform: 'There are no unsent messages in change set ' , nameLine]. self systemNavigation browseMessageList: (augList select: [:each | unsent includes: each methodSymbol]) name: 'Unsent messages in ' , nameLine! ! !ParagraphEditor methodsFor: 'explain'! explainClass: symbol "Is symbol a class variable or a pool variable?" | class reply classes | (model respondsTo: #selectedClassOrMetaClass) ifFalse: [^ nil]. (class _ model selectedClassOrMetaClass) ifNil: [^ nil]. "no class is selected" (class isKindOf: Metaclass) ifTrue: [class _ class soleInstance]. classes _ (Array with: class) , class allSuperclasses. "class variables" reply _ classes detect: [:each | (each classVarNames detect: [:name | symbol = name] ifNone: []) ~~ nil] ifNone: []. reply == nil ifFalse: [^ '"is a class variable, defined in class ' , reply printString , '"\' withCRs , 'SystemNavigation new browseAllCallsOn: (' , reply printString , ' classPool associationAt: #' , symbol , ').']. "pool variables" classes do: [:each | (each sharedPools detect: [:pool | (pool includesKey: symbol) and: [reply _ pool. true]] ifNone: []) ~~ nil]. reply ifNil: [(Undeclared includesKey: symbol) ifTrue: [^ '"is an undeclared variable.' , '"\' withCRs , 'SystemNavigation browseAllCallsOn: (Undeclared associationAt: #' , symbol , ').']] ifNotNil: [classes _ WriteStream on: Array new. self systemNavigation allBehaviorsDo: [:each | (each sharedPools detect: [:pool | pool == reply] ifNone: []) ~~ nil ifTrue: [classes nextPut: each]]. "Perhaps not print whole list of classes if too long. (unlikely)" ^ '"is a pool variable from the pool ' , (Smalltalk keyAtIdentityValue: reply) asString , ', which is used by the following classes ' , classes contents printString , '"\' withCRs , 'SystemNavigation new browseAllCallsOn: (' , (Smalltalk keyAtIdentityValue: reply) asString , ' associationAt: #' , symbol , ').']. ^ nil! explainGlobal: symbol "Is symbol a global variable?" | reply classes | reply _ Smalltalk at: symbol ifAbsent: [^nil]. (reply isKindOf: Behavior) ifTrue: [^'"is a global variable. ' , symbol , ' is a class in category ', reply category, '."', '\' withCRs, 'Browser newOnClass: ' , symbol , '.']. symbol == #Smalltalk ifTrue: [^'"is a global. Smalltalk is the only instance of SystemDictionary and holds all global variables."']. reply class == Dictionary ifTrue: [classes _ Set new. self systemNavigation allBehaviorsDo: [:each | (each sharedPools detect: [:pool | pool == reply] ifNone: []) ~~ nil ifTrue: [classes add: each]]. classes _ classes printString. ^'"is a global variable. ' , symbol , ' is a Dictionary. It is a pool which is used by the following classes' , (classes copyFrom: 4 to: classes size) , '"']. ^'"is a global variable. ' , symbol , ' is ' , reply printString , '"'! ! !Environment class methodsFor: 'system conversion'! computePrerequisites "We say one environment is a prerequisite of another if classes defined in the other inherit from classes in the first. Compute a dictionary with an entry for every non-kernel environment. That entry is another dictionary giving the names of any prerequisite environments and the list of classes that require it." "Environment computePrerequisites." "<-- inspect this" | bigCats bigCat preReqs supCat dict kernelCategories | bigCats _ IdentityDictionary new. kernelCategories _ Environment new kernelCategories. self flag: #NotSureOfTheSmalltalkReference. "sd" Smalltalk allClasses do: [:cl | bigCat _ (cl category asString copyUpTo: '-' first) asSymbol. (kernelCategories includes: bigCat) ifTrue: [bigCat _ #Kernel]. bigCats at: cl name put: bigCat]. preReqs _ IdentityDictionary new. self flag: #NotSureAboutTheSmalltalkReferenceHere. "sd" Smalltalk allClasses do: [:cl | cl superclass ifNotNil: [bigCat _ bigCats at: cl name. supCat _ bigCats at: cl superclass name. bigCat ~~ supCat ifTrue: [dict _ preReqs at: bigCat ifAbsent: [preReqs at: bigCat put: IdentityDictionary new]. dict at: supCat put: ((dict at: supCat ifAbsent: [Array new]) copyWith: cl name)]]]. ^ preReqs! ! !MessageNames methodsFor: 'selector list'! messageList "Answer the receiver's message list, computing it if necessary. The way to force a recomputation is to set the messageList to nil" messageList ifNil: [messageList _ selectorListIndex == 0 ifTrue: [#()] ifFalse: [self systemNavigation allImplementorsOf: (selectorList at: selectorListIndex)]. self messageListIndex: (messageList size > 0 ifTrue: [1] ifFalse: [0])]. ^ messageList! ! !MessageNames methodsFor: 'search'! showOnlyImplementedSelectors "Caution -- can be slow!! Filter my selector list down such that it only shows selectors that are actually implemented somewhere in the system." self okToChange ifTrue: [Cursor wait showWhile: [selectorList _ self systemNavigation allSelectorsWithAnyImplementorsIn: selectorList. self changed: #selectorList. self changed: #messageList]]! computeSelectorListFromSearchString "Compute selector list from search string" | raw sorted | searchString _ searchString asString copyWithout: $ . selectorList _ Cursor wait showWhile: [raw _ Symbol selectorsContaining: searchString. sorted _ raw as: SortedCollection. sorted sortBlock: [:x :y | x asLowercase <= y asLowercase]. sorted asArray]. selectorList size > 19 ifFalse: ["else the following filtering is considered too expensive. This 19 should be a system-maintained Parameter, someday" selectorList _ self systemNavigation allSelectorsWithAnyImplementorsIn: selectorList]. ^ selectorList! ! !Dictionary methodsFor: 'removing'! unreferencedKeys "TextConstants unreferencedKeys" | n | ^ 'Scanning for references . . .' displayProgressAt: Sensor cursorPoint from: 0 to: self size during: [:bar | n _ 0. self keys select: [:key | bar value: (n _ n + 1). (SystemNavigation new allCallsOn: (self associationAt: key)) isEmpty]]! ! !Morph methodsFor: 'naming'! renameTo: aName "Set Player name in costume. Update Viewers. Fix all tiles (old style). fix References. New tiles: recompile, and recreate open scripts. If coming in from disk, and have name conflict, References will already have new name. " | aPresenter putInViewer aPasteUp renderer oldKey assoc classes oldName | oldName _ self knownName. (renderer _ self topRendererOrSelf) setNameTo: aName. putInViewer _ false. ((aPresenter _ self presenter) isNil or: [renderer player isNil]) ifFalse: [putInViewer _ aPresenter currentlyViewing: renderer player. putInViewer ifTrue: [renderer player viewerFlapTab hibernate]]. "empty it temporarily" (aPasteUp _ self topPasteUp) ifNotNil: [aPasteUp allTileScriptingElements do: [:m | m bringUpToDate]]. "Fix References dictionary. See restoreReferences to know why oldKey is already aName, but oldName is the old name." oldKey _ References keyAtIdentityValue: renderer player ifAbsent: []. oldKey ifNotNil: [assoc _ References associationAt: oldKey. oldKey = aName ifFalse: ["normal rename" assoc key: (renderer player uniqueNameForReferenceFrom: aName). References rehash]]. putInViewer ifTrue: [aPresenter viewMorph: self]. "recreate my viewer" oldKey ifNil: [^ aName]. "Force strings in tiles to be remade with new name. New tiles only." Preferences universalTiles ifFalse: [^ aName]. classes _ (SystemNavigation new allCallsOn: assoc) collect: [:each | each classSymbol]. classes asSet do: [:clsName | (Smalltalk at: clsName) replaceSilently: oldName to: aName]. "replace in text body of all methods. Can be wrong!!" "Redo the tiles that are showing. This is also done in caller in unhibernate. " aPasteUp ifNotNil: [aPasteUp allTileScriptingElements do: [:mm | "just ScriptEditorMorphs" nil. (mm isKindOf: ScriptEditorMorph) ifTrue: [((mm playerScripted class compiledMethodAt: mm scriptName) hasLiteral: assoc) ifTrue: [mm hibernate; unhibernate]]]]. ^ aName! ! !CleanKernelTest methodsFor: 'query'! testRemoveAllSelect self assert: (self isSelector: #allSelect: deprecatedInClass: #SystemDictionary). ! testRemoveAllPrimitiveMessages self assert: (self isSelector: #allPrimitiveMessages deprecatedInClass: #SystemDictionary). ! testRemoveAllGlobalRefs self assert: (self isSelector: #allGlobalRefs deprecatedInClass: #SystemDictionary). ! testRemoveAllImplementorsOfLocalTo self assert: (self isSelector: #allImplementorsOf:localTo: deprecatedInClass: #SystemDictionary). ! testAllCallsOnAnd "self run: #testAllCallsOnAnd" self class forgetDoIts. self assert: (SystemNavigation new allCallsOn: #zoulouSymbol and: #callingAThirdMethod) size = 2. self assert: (SystemNavigation new allCallsOn: #callingAThirdMethod and: #inform:) size = 1! testRemoveAllImplementorsOf self assert: (self isSelector: #allImplementorsOf: deprecatedInClass: #SystemDictionary). ! testAllMethodsSelect "self run: #testAllMethodsSelect" | res | res _ SystemNavigation new allMethodsSelect: [:each | each messages includes: #zoulouSymbol]. self assert: res size = 1. self assert: (res at: 1) methodSymbol = #callingAThirdMethod! testRemoveAllUnSentMessagesWithout self assert: (self isSelector: #allUnSentMessagesWithout: deprecatedInClass: #SystemDictionary). ! testRemoveAllSentMessagesWithout self assert: (self isSelector: #allSentMessagesWithout: deprecatedInClass: #SystemDictionary). ! testRemoveAllObjectsDo self assert: (self isSelector: #allObjectsDo: deprecatedInClass: #SystemDictionary). ! testRemoveAllUnimplementedCalls self assert: (self isSelector: #allUnimplementedCalls deprecatedInClass: #SystemDictionary). ! testRemoveAllUnSentMessages self assert: (self isSelector: #allUnSentMessages deprecatedInClass: #SystemDictionary). ! testIsThereAnImplementorOf "self run: #testIsThereAnImplementorOf" self deny: (SystemNavigation new isThereAnImplementorOf: #nobodyImplementsThis) . self assert: (SystemNavigation new isThereAnImplementorOf: #zoulouSymbol).! testRemoveAllObjectsSelect self assert: (self isSelector: #allObjectsSelect: deprecatedInClass: #SystemDictionary). ! testRemoveAllImplementedMessages self assert: (self isSelector: #allImplementedMessages deprecatedInClass: #SystemDictionary). ! testRemoveClassThatUnderstands self assert: (self isSelector: #classThatUnderstands: deprecatedInClass: #Behavior). self assert: (SystemNavigation new allCallsOn: #classThatUnderstands:) size = 2 "2 because one for this method and one for the noteDangerous method of the method finder"! testRemoveallUnSentMessagesIn self assert: (self isSelector: #allUnSentMessagesIn: deprecatedInClass: #SystemDictionary). ! testAllCallsOn "self run: #testAllCallsOn" self class forgetDoIts. self assert: (SystemNavigation new allCallsOn: #zoulouSymbol) size = 7. self assert: (SystemNavigation new allCallsOn: #callingAnotherMethod) size = 2! testRemoveallCallsOnAnd self assert: (self isSelector: #allCallsOn:and: deprecatedInClass: #SystemDictionary). ! testRemoveSelectorsWithAnyImplementorsIn self assert: (self isSelector: #selectorsWithAnyImplementorsIn: deprecatedInClass: #SystemDictionary). ! testRemoveAllSelectNoDoits self assert: (self isSelector: #allSelectNoDoits: deprecatedInClass: #SystemDictionary). ! testRemoveAllUnreferencedClassVariables self assert: (self isSelector: #allUnreferencedClassVariables deprecatedInClass: #ClassDescription). ! testRemoveAllBehaviorsDo self assert: (self isSelector: #allBehaviorsDo: deprecatedInClass: #SystemDictionary). ! testRemoveAllUnusedClassesWithout self assert: (self isSelector: #allUnusedClassesWithout: deprecatedInClass: #SystemDictionary). ! testRemoveallCallsOn self assert: (self isSelector: #allCallsOn: deprecatedInClass: #SystemDictionary)! testRemoveAllMethodsInCategory self assert: (self isSelector: #allMethodsInCategory: deprecatedInClass: #SystemDictionary)! testRemoveAllSentMessages self assert: (self isSelector: #allSentMessages deprecatedInClass: #SystemDictionary). ! testNumberOfImplementors "self run: #testNumberOfImplementors" self assert: (SystemNavigation new numberOfImplementorsOf: #nobodyImplementsThis) isZero. self assert: (SystemNavigation new numberOfImplementorsOf: #zoulouSymbol) = 2.! testRemoveAllMethodsWithSourceStringMatchCase self assert: (self isSelector: #allMethodsWithSourceString:matchCase: deprecatedInClass: #SystemDictionary). ! testRemoveAllGlobalRefsWithout self assert: (self isSelector: #allGlobalRefsWithout: deprecatedInClass: #SystemDictionary). ! testRemoveAllImplementedMessagesWithout self assert: (self isSelector: #allImplementedMessagesWithout: deprecatedInClass: #SystemDictionary). ! testRemoveAllPrimitiveMethodsInCategories self assert: (self isSelector: #allPrimitiveMethodsInCategories: deprecatedInClass: #SystemDictionary). ! testRemoveAllClassesImplementing self assert: (self isSelector: #allClassesImplementing: deprecatedInClass: #SystemDictionary). ! ! !SelectorBrowser methodsFor: 'as yet unclassified'! messageListIndex: anInteger "Set the selected message selector to be the one indexed by anInteger. Find all classes it is in." selectorIndex _ anInteger. selectorIndex = 0 ifTrue: [^ self]. classList _ self systemNavigation allImplementorsOf: self selectedMessageName. self markMatchingClasses. classListIndex _ 0. self changed: #messageListIndex. "update my selection" self changed: #classList! ! !PositionableStream methodsFor: 'fileIn/Out'! fileInAnnouncing: announcement "This is special for reading expressions from text that has been formatted with exclamation delimitors. The expressions are read and passed to the Compiler. Answer the result of compilation. Put up a progress report with the given announcement as the title." | val chunk | announcement displayProgressAt: Sensor cursorPoint from: 0 to: self size during: [:bar | [self atEnd] whileFalse: [bar value: self position. self skipSeparators. [ val _ (self peekFor: $!!) ifTrue: [ (Compiler evaluate: self nextChunk logged: false) scanFrom: self ] ifFalse: [ chunk _ self nextChunk. self checkForPreamble: chunk. Compiler evaluate: chunk logged: true ]. ] on: InMidstOfFileinNotification do: [ :ex | ex resume: true]. self skipStyleChunk]. self close]. "Note: The main purpose of this banner is to flush the changes file." Smalltalk logChange: '----End fileIn of ' , self name , '----'. self flag: #ThisMethodShouldNotBeThere. "sd" SystemNavigation new allBehaviorsDo: [ :cl | cl removeSelectorSimply: #DoIt; removeSelectorSimply: #DoItIn: ]. ^ val! ! !SystemNavigation methodsFor: 'query'! allClasses "currently returns all the classes defined in Smalltalk but could be customized for dealing with environments and in such a case would return on really all the classes" ^ Smalltalk allClasses ! allImplementorsOf: aSelector localTo: aClass "Answer a SortedCollection of all the methods that implement the message aSelector in, above, or below the given class." | aSet cls | aSet _ Set new. cls _ aClass theNonMetaClass. Cursor wait showWhile: [ cls withAllSuperAndSubclassesDoGently: [:class | (class includesSelector: aSelector) ifTrue: [aSet add: class name, ' ', aSelector]]. cls class withAllSuperAndSubclassesDoGently: [:class | (class includesSelector: aSelector) ifTrue: [aSet add: class name, ' ', aSelector]] ]. ^aSet asSortedCollection! allUnreferencedClassVariablesOf: aClass "Answer a list of the names of all the receiver's unreferenced class vars, including those defined in superclasses" | aList | aList _ OrderedCollection new. aClass withAllSuperclasses reverseDo: [:aSuperClass | aSuperClass classVarNames do: [:var | (self allCallsOn: (aSuperClass classPool associationAt: var)) isEmpty ifTrue: [aList add: var]]]. ^ aList! selectAllMethodsNoDoits: aBlock "Like allSelect:, but strip out Doits" | aCollection | aCollection _ SortedCollection new. Cursor execute showWhile: [self allBehaviorsDo: [:class | class selectorsDo: [:sel | (sel ~~ #DoIt and: [aBlock value: (class compiledMethodAt: sel)]) ifTrue: [aCollection add: (MethodReference new setStandardClass: class methodSymbol: sel)]]]]. ^ aCollection! allCallsOn: firstLiteral and: secondLiteral "Answer a SortedCollection of all the methods that call on both aLiteral and secondLiteral." | aCollection secondArray firstSpecial secondSpecial firstByte secondByte | self flag: #ShouldUseAllCallsOn:. "sd" aCollection _ SortedCollection new. firstSpecial _ Smalltalk hasSpecialSelector: firstLiteral ifTrueSetByte: [:b | firstByte _ b]. secondSpecial _ Smalltalk hasSpecialSelector: secondLiteral ifTrueSetByte: [:b | secondByte _ b]. Cursor wait showWhile: [ self allBehaviorsDo: [:class | secondArray _ class whichSelectorsReferTo: secondLiteral special: secondSpecial byte: secondByte. ((class whichSelectorsReferTo: firstLiteral special: firstSpecial byte: firstByte) select: [:aSel | (secondArray includes: aSel)]) do: [:sel | aCollection add: ( MethodReference new setStandardClass: class methodSymbol: sel ) ] ] ]. ^aCollection! allSentMessagesWithout: classesAndMessagesPair "Answer the set of selectors which are sent somewhere in the system, computed in the absence of the supplied classes and messages." | sent absentClasses absentSelectors | sent _ IdentitySet new: CompiledMethod instanceCount. absentClasses _ classesAndMessagesPair first. absentSelectors _ classesAndMessagesPair second. self flag: #shouldBeRewrittenUsingSmalltalkAllClassesDo:. "sd 29/04/03" Cursor execute showWhile: [Smalltalk classNames do: [:cName | ((absentClasses includes: cName) ifTrue: [{}] ifFalse: [{Smalltalk at: cName. (Smalltalk at: cName) class}]) do: [:cl | (absentSelectors isEmpty ifTrue: [cl selectors] ifFalse: [cl selectors copyWithoutAll: absentSelectors]) do: [:sel | "Include all sels, but not if sent by self" (cl compiledMethodAt: sel) literals do: [:m | (m isMemberOf: Symbol) ifTrue: ["might be sent" m == sel ifFalse: [sent add: m]]. (m isMemberOf: Array) ifTrue: ["might be performed" m do: [:x | (x isMemberOf: Symbol) ifTrue: [x == sel ifFalse: [sent add: x]]]]]]]]. "The following may be sent without being in any literal frame" 1 to: Smalltalk specialSelectorSize do: [:index | sent add: (Smalltalk specialSelectorAt: index)]]. Smalltalk presumedSentMessages do: [:sel | sent add: sel]. ^ sent! allUnusedClassesWithout: classesAndMessagesPair "Enumerates all classes in the system and returns a list of those that are apparently unused. A class is considered in use if it (a) has subclasses or (b) is referred to by some method or (c) has its name in use as a literal." "SystemNavigation new unusedClasses" | unused cl | unused _ Smalltalk classNames asIdentitySet copyWithoutAll: (self allGlobalRefsWithout: classesAndMessagesPair). ^ unused reject: [:cName | cl _ Smalltalk at: cName. cl subclasses isEmpty not or: [cl inheritsFrom: FileDirectory]]! allClassesImplementing: aSelector "Answer an Array of all classes that implement the message aSelector." | aCollection | aCollection _ ReadWriteStream on: Array new. self systemNavigation allBehaviorsDo: [:class | (class includesSelector: aSelector) ifTrue: [aCollection nextPut: class]]. ^ aCollection contents! allUnSentMessagesWithout: classesAndMessagesPair "Answer the set of selectors that are implemented but not sent, computed in the absence of the supplied classes and messages." ^ (self allImplementedMessagesWithout: classesAndMessagesPair) copyWithoutAll: (self allSentMessagesWithout: classesAndMessagesPair)! allPrimitiveMethodsInCategories: aList "Answer an OrderedCollection of all the methods that are implemented by primitives in the given categories. 1/26/96 sw" "SystemNavigation new allPrimitiveMethodsInCategories: #('Collections-Streams' 'Files-Streams' 'Files-Abstract' 'Files-Macintosh')" | aColl method | aColl _ OrderedCollection new: 200. Cursor execute showWhile: [self systemNavigation allBehaviorsDo: [:aClass | (aList includes: (SystemOrganization categoryOfElement: aClass theNonMetaClass name asString) asString) ifTrue: [aClass selectorsDo: [:sel | method _ aClass compiledMethodAt: sel. method primitive ~= 0 ifTrue: [aColl addLast: aClass name , ' ' , sel , ' ' , method primitive printString]]]]]. ^ aColl! allUnSentMessages "SystemNavigation new allUnSentMessages" "Answer the set of selectors that are implemented by some object in the system but not sent by any." ^ self allUnSentMessagesWithout: {{}. {}}! allSentMessages "Answer the set of selectors which are sent somewhere in the system." ^ self allSentMessagesWithout: {{}. {}}! allObjectsSelect: aBlock "Evaluate the argument, aBlock, for each object in the system excluding SmallIntegers. Return a collection af all objects for whom the value is true. " ^ Array streamContents: [:s | self allObjectsDo: [:object | (aBlock value: object) ifTrue: [s nextPut: object]]]! selectAllMethods: aBlock "Answer a SortedCollection of each method that, when used as the block argument to aBlock, gives a true result." | aCollection | aCollection _ SortedCollection new. Cursor execute showWhile: [self allBehaviorsDo: [:class | class selectorsDo: [:sel | (aBlock value: (class compiledMethodAt: sel)) ifTrue: [aCollection add: (MethodReference new setStandardClass: class methodSymbol: sel)]]]]. ^ aCollection! allUnSentMessagesIn: selectorSet "Answer the subset of selectorSet which are not sent anywhere in the system. " ^ selectorSet copyWithoutAll: self allSentMessages! allMethodsWithSourceString: aString matchCase: caseSensitive "Answer a SortedCollection of all the methods that contain, in source code, aString as a substring. Search the class comments also" | list classCount adder | list _ Set new. adder _ [ :mrClass :mrSel | list add: ( MethodReference new setStandardClass: mrClass methodSymbol: mrSel)]. 'Searching all source code...' displayProgressAt: Sensor cursorPoint from: 0 to: Smalltalk classNames size during: [:bar | classCount _ 0. Smalltalk allClassesDo: [:class | bar value: (classCount _ classCount + 1). (Array with: class with: class class) do: [:cl | cl selectorsDo: [:sel | ((cl sourceCodeAt: sel) findString: aString startingAt: 1 caseSensitive: caseSensitive) > 0 ifTrue: [ sel == #DoIt ifFalse: [adder value: cl value: sel]]]. (cl organization classComment asString findString: aString startingAt: 1 caseSensitive: caseSensitive) > 0 ifTrue: [ adder value: cl value: #Comment]. ]]]. ^ list asSortedCollection! allCallsOn: aLiteral "Answer a Collection of all the methods that call on aLiteral even deeply embedded in literal array." "self new browseAllCallsOn: #open:label:." | aCollection special thorough aList byte | aCollection _ OrderedCollection new. special _ Smalltalk hasSpecialSelector: aLiteral ifTrueSetByte: [:b | byte _ b]. thorough _ (aLiteral isMemberOf: Symbol) and: ["Possibly search for symbols imbedded in literal arrays" Preferences thoroughSenders]. Cursor wait showWhile: [self allBehaviorsDo: [:class | aList _ thorough ifTrue: [class thoroughWhichSelectorsReferTo: aLiteral special: special byte: byte] ifFalse: [class whichSelectorsReferTo: aLiteral special: special byte: byte]. aList do: [:sel | sel == #DoIt ifFalse: [aCollection add: (MethodReference new setStandardClass: class methodSymbol: sel)]]]]. ^ aCollection! allGlobalRefsWithout: classesAndMessagesPair "Answer a set of symbols that may be refs to Global names. In some sense we should only need the associations, but this will also catch, eg, HTML tag types. This method computes its result in the absence of specified classes and messages." "may be a problem if namespaces are introduced as for the moment only Smalltalk is queried. sd 29/4/03" | globalRefs absentClasses absentSelectors | globalRefs _ IdentitySet new: CompiledMethod instanceCount. absentClasses _ classesAndMessagesPair first. absentSelectors _ classesAndMessagesPair second. self flag: #shouldBeRewrittenUsingSmalltalkAllClassesDo:. "sd 29/04/03" Cursor execute showWhile: [Smalltalk classNames do: [:cName | ((absentClasses includes: cName) ifTrue: [{}] ifFalse: [{Smalltalk at: cName. (Smalltalk at: cName) class}]) do: [:cl | (absentSelectors isEmpty ifTrue: [cl selectors] ifFalse: [cl selectors copyWithoutAll: absentSelectors]) do: [:sel | "Include all capitalized symbols for good measure" (cl compiledMethodAt: sel) literals do: [:m | ((m isMemberOf: Symbol) and: [m size > 0 and: [m first isUppercase]]) ifTrue: [globalRefs add: m]. (m isMemberOf: Array) ifTrue: [m do: [:x | ((x isMemberOf: Symbol) and: [x size > 0 and: [x first isUppercase]]) ifTrue: [globalRefs add: x]]]. m isVariableBinding ifTrue: [m key ifNotNil: [globalRefs add: m key]]]]]]]. ^ globalRefs! allObjectsDo: aBlock "Evaluate the argument, aBlock, for each object in the system excluding SmallIntegers." | object | object _ self someObject. [0 == object] whileFalse: [aBlock value: object. object _ object nextObject]! allSelectorsWithAnyImplementorsIn: selectorList "Answer the subset of the given list which represent method selectors which have at least one implementor in the system." | good | good _ OrderedCollection new. self systemNavigation allBehaviorsDo: [:class | selectorList do: [:aSelector | (class includesSelector: aSelector) ifTrue: [good add: aSelector]]]. ^ good asSet asSortedArray" SystemNavigation new selectorsWithAnyImplementorsIn: #( contents contents: nuts) "! allClassesDo: aBlock "currently returns all the classes defined in Smalltalk but could be customized for dealing with environments and in such a case would work on really all the classes" ^ Smalltalk allClassesDo: aBlock ! allImplementedMessagesWithout: classesAndMessagesPair "Answer a Set of all the messages that are implemented in the system, computed in the absence of the supplied classes and messages. Note this reports messages that are in the absent selectors set." | messages absentClasses | messages _ IdentitySet new: CompiledMethod instanceCount. absentClasses _ classesAndMessagesPair first. self flag: #shouldBeRewrittenUsingSmalltalkAllClassesDo:. "sd 29/04/03" Cursor execute showWhile: [Smalltalk classNames do: [:cName | ((absentClasses includes: cName) ifTrue: [{}] ifFalse: [{Smalltalk at: cName. (Smalltalk at: cName) class}]) do: [:cl | messages addAll: cl selectors]]]. ^ messages! allImplementedMessages "Answer a Set of all the messages that are implemented in the system." ^ self allImplementedMessagesWithout: {{}. {}}! allUnimplementedCalls "Answer an Array of each message that is sent by an expression in a method but is not implemented by any object in the system." | aStream secondStream all | all _ self systemNavigation allImplementedMessages. aStream _ WriteStream on: (Array new: 50). Cursor execute showWhile: [self systemNavigation allBehaviorsDo: [:cl | cl selectorsDo: [:sel | secondStream _ WriteStream on: (String new: 5). (cl compiledMethodAt: sel) messages do: [:m | (all includes: m) ifFalse: [secondStream nextPutAll: m; space]]. secondStream position = 0 ifFalse: [aStream nextPut: cl name , ' ' , sel , ' calls: ' , secondStream contents]]]]. ^ aStream contents! numberOfImplementorsOf: aSelector "Answer a count of the implementors of the given selector found in the system" "self new numberOfImplementorsOf: #contents. self new numberOfImplementorsOf: #nobodyImplementsThis. self new numberOfimplementorsOf: #numberOfImplementorsOf:." | aCount | aCount _ 0. self allBehaviorsDo: [:class | (class includesSelector: aSelector) ifTrue: [aCount _ aCount + 1]]. ^ aCount! isThereAnImplementorOf: aSelector "Answer true if there is at least one implementor of the selector found in the system, false if there are no implementors" "self new isThereAnImplementorOf: #contents. self new isThereAnImplementorOf: #nobodyImplementsThis." self allBehaviorsDo: [:class | (class includesSelector: aSelector) ifTrue: [^ true]]. ^ false! allImplementorsOf: aSelector "Answer a SortedCollection of all the methods that implement the message aSelector." | aCollection | aCollection _ SortedCollection new. Cursor wait showWhile: [self allBehaviorsDo: [:class | (class includesSelector: aSelector) ifTrue: [aCollection add: (MethodReference new setStandardClass: class methodSymbol: aSelector)]]]. ^ aCollection! allGlobalRefs "Answer a set of symbols that may be refs to Global names. In some sense we should only need the associations, but this will also catch, eg, HTML tag types." ^ self allGlobalRefsWithout: {{}. {}}! allMethodsSelect: aBlock "Answer a SortedCollection of each method that, when used as the block argument to aBlock, gives a true result." | aCollection | aCollection _ SortedCollection new. Cursor execute showWhile: [self allBehaviorsDo: [:class | class selectorsDo: [:sel | (aBlock value: (class compiledMethodAt: sel)) ifTrue: [aCollection add: (MethodReference new setStandardClass: class methodSymbol: sel)]]]]. ^ aCollection! allMethodsNoDoitsSelect: aBlock "Like allSelect:, but strip out Doits" | aCollection | aCollection _ SortedCollection new. Cursor execute showWhile: [self allBehaviorsDo: [:class | class selectorsDo: [:sel | (sel ~~ #DoIt and: [aBlock value: (class compiledMethodAt: sel)]) ifTrue: [aCollection add: (MethodReference new setStandardClass: class methodSymbol: sel)]]]]. ^ aCollection! allBehaviorsDo: aBlock "Evaluate the argument, aBlock, for each kind of Behavior in the system (that is, Object and its subclasses). ar 7/15/1999: The code below will not enumerate any obsolete or anonymous behaviors for which the following should be executed: Smalltalk allObjectsDo:[:obj| obj isBehavior ifTrue:[aBlock value: obj]]. but what follows is way faster than enumerating all objects." aBlock value: ProtoObject. ProtoObject allSubclassesDoGently: aBlock. "don't bring in ImageSegments" "Classes outside the ProtoObject hierarchy" Class subclassesDo: [:aClass | (aClass == ProtoObject class or: [aClass isInMemory not or: [aClass isMeta not]]) ifFalse: ["Enumerate the non-meta class and its subclasses" aBlock value: aClass soleInstance. aClass soleInstance allSubclassesDoGently: aBlock]].! allPrimitiveMethods "Answer an OrderedCollection of all the methods that are implemented by primitives." | aColl method | aColl _ OrderedCollection new: 200. Cursor execute showWhile: [self systemNavigation allBehaviorsDo: [:class | class selectorsDo: [:sel | method _ class compiledMethodAt: sel. method primitive ~= 0 ifTrue: [aColl addLast: class name , ' ' , sel , ' ' , method primitive printString]]]]. ^ aColl! ! !SystemNavigation methodsFor: 'ui'! confirmRemovalOf: aSelector on: aClass "Determine if it is okay to remove the given selector. Answer 1 if it should be removed, 2 if it should be removed followed by a senders browse, and 3 if it should not be removed." | count aMenu answer caption allCalls | allCalls _ self allCallsOn: aSelector. (count _ allCalls size) == 0 ifTrue: [^ 1]. "no senders -- let the removal happen without warning" count == 1 ifTrue: [(allCalls first actualClass == aClass and: [allCalls first methodSymbol == aSelector]) ifTrue: [^ 1]]. "only sender is itself" aMenu _ PopUpMenu labels: 'Remove it Remove, then browse senders Don''t remove, but show me those senders Forget it -- do nothing -- sorry I asked'. caption _ 'This message has ' , count printString , ' sender'. count > 1 ifTrue: [caption _ caption copyWith: $s]. answer _ aMenu startUpWithCaption: caption. answer == 3 ifTrue: [self browseMessageList: allCalls name: 'Senders of ' , aSelector autoSelect: aSelector keywords first]. answer == 0 ifTrue: [answer _ 3]. "If user didn't answer, treat it as cancel" ^ answer min: 3! ! !SystemNavigation methodsFor: 'browse'! browseAllCallsOn: aLiteral "Create and schedule a message browser on each method that refers to aLiteral. For example, SystemNavigation new browseAllCallsOn: #open:label:." (aLiteral isKindOf: LookupKey) ifTrue: [^ self browseMessageList: (self allCallsOn: aLiteral) asSortedCollection name: 'Users of ' , aLiteral key autoSelect: aLiteral key]. self browseMessageList: (self allCallsOn: aLiteral) asSortedCollection name: 'Senders of ' , aLiteral autoSelect: aLiteral keywords first! browseMethodsWithSourceString: aString "SystemNavigation new browseMethodsWithSourceString: 'SourceString'" "Launch a browser on all methods whose source code contains aString as a substring." | caseSensitive suffix | suffix _ (caseSensitive _ Sensor shiftPressed) ifTrue: [' (case-sensitive)'] ifFalse: [' (use shift for case-sensitive)']. ^ self browseMessageList: (self allMethodsWithSourceString: aString matchCase: caseSensitive) name: 'Methods containing ' , aString printString , suffix autoSelect: aString! browseAllImplementorsOf: selector "Create and schedule a message browser on each method that implements the message whose selector is the argument, selector. For example, Smalltalk browseAllImplementorsOf: #at:put:." ^ self browseMessageList: (self allImplementorsOf: selector) name: 'Implementors of ' , selector! browseAllSelect: aBlock name: aName autoSelect: autoSelectString "Create and schedule a message browser on each method that, when used as the block argument to aBlock gives a true result. Do not return an #DoIt traces." "self new browseAllSelect: [:method | method numLiterals > 10] name: 'Methods with more than 10 literals' autoSelect: 'isDigit'" ^ self browseMessageList: (self allMethodsNoDoitsSelect: aBlock) name: aName autoSelect: autoSelectString! browseAllSelect: aBlock "Create and schedule a message browser on each method that, when used as the block argument to aBlock gives a true result. For example, SystemNavigation new browseAllSelect: [:method | method numLiterals > 10]." ^ self browseMessageList: (self allMethodsSelect: aBlock) name: 'selected messages'! browseAllImplementorsOfList: selectorList title: aTitle "Create and schedule a message browser on each method that implements the message whose selector is in the argument selectorList. For example, self new browseAllImplementorsOf: #(at:put: size). 1/16/96 sw: this variant adds the title argument. 1/24/96 sw: use a SortedCollection 2/1/96 sw: show normal cursor" | implementorLists flattenedList | implementorLists _ selectorList collect: [:each | self allImplementorsOf: each]. flattenedList _ SortedCollection new. implementorLists do: [:each | flattenedList addAll: each]. Cursor normal show. ^ self browseMessageList: flattenedList name: aTitle! ! !LookupKey methodsFor: 'bindings'! recompileBindingsAnnouncing: aBool "Make the receiver (a global read-write binding) be a read-only binding" aBool ifTrue: [Utilities informUserDuring: [:bar | (SystemNavigation new allCallsOn: self) do: [:mref | bar value: 'Recompiling ' , mref asStringOrText. mref actualClass recompile: mref methodSymbol]]] ifFalse: [(SystemNavigation new allCallsOn: self) do: [:mref | mref actualClass recompile: mref methodSymbol]]! ! !Browser methodsFor: 'class functions'! renameClass | oldName newName obs | classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. oldName _ self selectedClass name. newName _ self request: 'Please type new class name' initialAnswer: oldName. newName = '' ifTrue: [^ self]. "Cancel returns ''" newName _ newName asSymbol. newName = oldName ifTrue: [^ self]. (Smalltalk includesKey: newName) ifTrue: [^ self error: newName , ' already exists']. self selectedClass rename: newName. self changed: #classList. self classListIndex: ((systemOrganizer listAtCategoryNamed: self selectedSystemCategoryName) indexOf: newName). obs _ self systemNavigation allCallsOn: (Smalltalk associationAt: newName). obs isEmpty ifFalse: [self systemNavigation browseMessageList: obs name: 'Obsolete References to ' , oldName autoSelect: oldName]! ! !StringHolder methodsFor: 'message list menu'! browseUnusedMethods | classes unsent messageList cls | (cls _ self selectedClass) ifNil: [^ self]. classes _ Array with: cls with: cls class. unsent _ Set new. classes do: [:c | unsent addAll: c selectors]. unsent _ self systemNavigation allUnSentMessagesIn: unsent. messageList _ OrderedCollection new. classes do: [:c | (c selectors select: [:s | unsent includes: s]) asSortedCollection do: [:sel | messageList add: c name , ' ' , sel]]. self systemNavigation browseMessageList: messageList name: 'Unsent Methods in ' , cls name! ! !Symbol class methodsFor: 'class initialization'! compareTiming " Symbol compareTiming " | answer t selectorList implementorLists flattenedList md | answer _ WriteStream on: String new. Smalltalk timeStamp: answer. answer cr; cr. answer nextPutAll: MethodDictionary instanceCount printString , ' method dictionaries'; cr; cr. answer nextPutAll: (MethodDictionary allInstances inject: 0 into: [:sum :each | sum + each size]) printString , ' method dictionary entries'; cr; cr. md _ MethodDictionary allInstances. t _ [100 timesRepeat: [md do: [:each | each includesKey: #majorShrink]]] timeToRun. answer nextPutAll: t printString , ' ms to check all method dictionaries for #majorShrink 1000 times'; cr; cr. selectorList _ Symbol selectorsContaining: 'help'. t _ [3 timesRepeat: [selectorList collect: [:each | SystemNavigation new allImplementorsOf: each]]] timeToRun. answer nextPutAll: t printString , ' ms to do #allImplementorsOf: for ' , selectorList size printString , ' selectors like *help* 3 times'; cr; cr. t _ [3 timesRepeat: [selectorList do: [:eachSel | md do: [:eachMd | eachMd includesKey: eachSel]]]] timeToRun. answer nextPutAll: t printString , ' ms to do #includesKey: for ' , md size printString , ' methodDicts for ' , selectorList size printString , ' selectors like *help* 3 times'; cr; cr. #('help' 'majorShrink' ) do: [:substr | answer nextPutAll: (Symbol selectorsContaining: substr) size printString , ' selectors containing "' , substr , '"'; cr. t _ [3 timesRepeat: [selectorList _ Symbol selectorsContaining: substr]] timeToRun. answer nextPutAll: t printString , ' ms to find Symbols containing *' , substr , '* 3 times'; cr. t _ [3 timesRepeat: [selectorList _ Symbol selectorsContaining: substr. implementorLists _ selectorList collect: [:each | Smalltalk allImplementorsOf: each]. flattenedList _ SortedCollection new. implementorLists do: [:each | flattenedList addAll: each]]] timeToRun. answer nextPutAll: t printString , ' ms to find implementors of *' , substr , '* 3 times'; cr; cr]. StringHolder new contents: answer contents; openLabel: 'timing'! ! !ClassOrganizer methodsFor: 'systemNavigation'! systemNavigation ^ SystemNavigation new! ! !ClassOrganizer methodsFor: 'fileIn/Out'! objectForDataStream: refStrm | dp | "I am about to be written on an object file. Write a path to me in the other system instead." self systemNavigation allBehaviorsDo: [:aClass | aClass organization == self ifTrue: [ (refStrm insideASegment and: [aClass isSystemDefined not]) ifTrue: [ ^ self]. "do trace me" (aClass isKindOf: Class) ifTrue: [ dp _ DiskProxy global: aClass name selector: #organization args: #(). refStrm replace: self with: dp. ^ dp]]]. ^ self "in desparation" ! ! !Vocabulary class methodsFor: 'queries'! instanceWhoRespondsTo: aSelector "Find the most likely class that responds to aSelector. Return an instance of it. Look in vocabularies to match the selector." "Most eToy selectors are for Players" | mthRefs | ((self vocabularyNamed: #eToy) includesSelector: aSelector) ifTrue: [aSelector == #+ ifFalse: [^ Player new costume: Morph new]]. "Numbers are a problem" ((self vocabularyNamed: #Number) includesSelector: aSelector) ifTrue: [^ 1]. "Is a Float any different?" "String Point Time Date" #() do: [:nn | ((self vocabularyNamed: nn) includesSelector: aSelector) ifTrue: ["Ask Scott how to get a prototypical instance" ^ (Smalltalk at: nn) new]]. mthRefs _ SystemNavigation new allImplementorsOf: aSelector. "every one who implements the selector" mthRefs sortBlock: [:a :b | (Smalltalk at: a classSymbol) allSuperclasses size < (Smalltalk at: b classSymbol) allSuperclasses size]. mthRefs size > 0 ifTrue: [^ (Smalltalk at: mthRefs first classSymbol) new]. ^ Error new! ! !CompiledMethod methodsFor: 'printing'! who "Answer an Array of the class in which the receiver is defined and the selector to which it corresponds." | sel | SystemNavigation new allBehaviorsDo: [:class | (sel _ class methodDict keyAtIdentityValue: self ifAbsent: [nil]) ifNotNil: [^Array with: class with: sel]]. ^ Array with: #unknown with: #unknown ! ! !ClassDescription methodsFor: 'deprecated'! allUnreferencedClassVariables self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allUnreferencedClassVariablesOf: instead'! ! !ClassDescription methodsFor: 'method dictionary'! allMethodsInCategory: aName "Answer a list of all the method categories of the receiver and all its superclasses " | aColl | aColl _ OrderedCollection new. self withAllSuperclasses do: [:aClass | aColl addAll: (aName = ClassOrganizer allCategory ifTrue: [aClass organization allMethodSelectors] ifFalse: [aClass organization listAtCategoryNamed: aName])]. ^ aColl asSet asSortedArray "TileMorph allMethodsInCategory: #initialization"! ! !ClassListBrowser class methodsFor: 'examples'! example2 "Put up a ClassListBrowser that shows all classes whose names start with the letter S" self new initForClassesNamed: (self systemNavigation allClasses collect: [:c | c name] thenSelect: [:aName | aName first == $S]) title: 'All classes starting with S' "ClassListBrowser example2"! ! !ClassListBrowser class methodsFor: 'instance creation'! browseClassesSatisfying: classBlock title: aTitle "Put up a ClassListBrowser showing all classes that satisfy the classBlock." self new initForClassesNamed: (self systemNavigation allClasses select: [:c | (classBlock value: c) == true] thenCollect: [:c | c name]) title: aTitle! ! !MessageSet methodsFor: 'filtering'! filterToUnsentMessages "Filter the receiver's list down to only those items which have no senders" self filterFrom: [:aClass :aSelector | (self systemNavigation allCallsOn: aSelector) isEmpty]! ! !EToyVocabulary methodsFor: 'initialization'! morphClassesDeclaringViewerAdditions "Answer a list of actual morph classes implementing #additionsToViewerCategories " | survivors | survivors _ OrderedCollection new. (SystemNavigation new allImplementorsOf: #additionsToViewerCategories) do: [:aMarker | (aMarker actualClass isMeta and: [aMarker actualClass soleInstance isKindOf: Morph class]) ifTrue: [survivors add: aMarker actualClass soleInstance]]. ^ survivors"EToyVocabulary basicNew morphClassesDeclaringViewerAdditions"! ! !SystemDictionary methodsFor: 'retrieving'! allClasses "Return all the class defines in the Smalltalk SystemDictionary" "Smalltalk allClasses" ^ self classNames collect: [:name | self at: name]! poolUsers "Answer a dictionary of pool name -> classes that refer to it." "Smalltalk poolUsers" | poolUsers pool refs | poolUsers _ Dictionary new. Smalltalk keys do: [:k | ((pool _ Smalltalk at: k) isKindOf: Dictionary) ifTrue: [refs _ self systemNavigation allClasses select: [:c | c sharedPools identityIncludes: pool] thenCollect: [:c | c name]. refs add: (self systemNavigation allCallsOn: (Smalltalk associationAt: k)). poolUsers at: k put: refs]]. ^ poolUsers! allClassesDo: aBlock "Evaluate the argument, aBlock, for each class in the system." (self classNames collect: [:name | self at: name]) do: aBlock! ! !SystemDictionary methodsFor: 'shrinking'! removeAllUnSentMessages "Smalltalk removeAllUnSentMessages" "[Smalltalk unusedClasses do: [:c | (Smalltalk at: c) removeFromSystem]. Smalltalk removeAllUnSentMessages > 0] whileTrue." "Remove all implementations of unsent messages." | sels n | sels _ self systemNavigation allUnSentMessages. "The following should be preserved for doIts, etc" "needed even after #majorShrink is pulled" #(#rehashWithoutBecome #compactSymbolTable #rebuildAllProjects #browseAllSelect: #printSpaceAnalysis #lastRemoval #scrollBarValue: #scrollBarMenuButtonPressed: #withSelectionFrom: #to: #removeClassNamed: #dragon: #hilberts: #mandala: #web #test3 #factorial #tinyBenchmarks #benchFib #newDepth: #restoreAfter: #forgetDoIts #zapAllMethods #obsoleteClasses #removeAllUnSentMessages #abandonSources #removeUnreferencedKeys #reclaimDependents #zapOrganization #condenseChanges #browseObsoleteReferences #subclass:instanceVariableNames:classVariableNames:poolDictionaries:category: #methodsFor:stamp: #methodsFor:stamp:prior: #instanceVariableNames: #startTimerInterruptWatcher #unusedClasses ) do: [:sel | sels remove: sel ifAbsent: []]. "The following may be sent by perform: in dispatchOnChar..." (ParagraphEditor classPool at: #CmdActions) asSet do: [:sel | sels remove: sel ifAbsent: []]. (ParagraphEditor classPool at: #ShiftCmdActions) asSet do: [:sel | sels remove: sel ifAbsent: []]. sels size = 0 ifTrue: [^ 0]. n _ 0. self systemNavigation allBehaviorsDo: [:x | n _ n + 1]. 'Removing ' , sels size printString , ' messages . . .' displayProgressAt: Sensor cursorPoint from: 0 to: n during: [:bar | n _ 0. self systemNavigation allBehaviorsDo: [:class | bar value: (n _ n + 1). sels do: [:sel | class removeSelectorSimply: sel]]]. ^ sels size! abandonTempNames "Replaces every method by a copy with no source pointer or encoded temp names." "Smalltalk abandonTempNames" | continue oldMethods newMethods n m | continue _ (self confirm: '-- CAUTION -- If you have backed up your system and are prepared to face the consequences of abandoning all source code, hit Yes. If you have any doubts, hit No, to back out with no harm done.'). continue ifFalse: [^ self inform: 'Okay - no harm done']. Smalltalk forgetDoIts; garbageCollect. oldMethods _ OrderedCollection new. newMethods _ OrderedCollection new. n _ 0. 'Removing temp names to save space...' displayProgressAt: Sensor cursorPoint from: 0 to: CompiledMethod instanceCount during: [:bar | self systemNavigation allBehaviorsDo: [:cl | cl selectors do: [:sel | bar value: (n _ n + 1). m _ cl compiledMethodAt: sel. oldMethods addLast: m. newMethods addLast: (m copyWithTrailerBytes: #(0))]]]. oldMethods asArray elementsExchangeIdentityWith: newMethods asArray. Smalltalk closeSourceFiles. self flag: #shouldUseAEnsureBlockToBeSureThatTheFileIsClosed. "sd: 17 April 2003" Preferences disable: #warnIfNoChangesFile. Preferences disable: #warnIfNoSourcesFile. ! unusedClasses "Enumerates all classes in the system and returns a list of those that are apparently unused. A class is considered in use if it (a) has subclasses or (b) is referred to by some method or (c) has its name in use as a literal. " "Smalltalk unusedClasses asSortedCollection" ^ self systemNavigation allUnusedClassesWithout: {{}. {}}! unusedClassesAndMethodsWithout: classesAndMessagesPair "Accepts and returns a pair: {set of class names. set of selectors}. It is expected these results will be diff'd with the normally unused results. " | classRemovals messageRemovals nClasses nMessages | (classRemovals _ IdentitySet new) addAll: classesAndMessagesPair first. (messageRemovals _ IdentitySet new) addAll: classesAndMessagesPair second. nClasses _ nMessages _ -1. ["As long as we keep making progress..." classRemovals size > nClasses or: [messageRemovals size > nMessages]] whileTrue: ["...keep trying for bigger sets of unused classes and selectors." nClasses _ classRemovals size. nMessages _ messageRemovals size. Utilities informUser: 'Iterating removals ' , (classesAndMessagesPair first isEmpty ifTrue: ['for baseline...'] ifFalse: ['for ' , classesAndMessagesPair first first , ' etc...']) , Character cr asString , nClasses printString , ' classes, ' , nMessages printString , ' messages. | |' during: ["spacers move menu off cursor" classRemovals addAll: (self systemNavigation allUnusedClassesWithout: {classRemovals. messageRemovals}). messageRemovals addAll: (self allUnSentMessagesWithout: {classRemovals. messageRemovals})]]. ^ {classRemovals. self allUnSentMessagesWithout: {classRemovals. messageRemovals}}! abandonSources "Smalltalk abandonSources" "Replaces every method by a copy with the 4-byte source pointer replaced by a string of all arg and temp names, followed by its length. These names can then be used to inform the decompiler. See stats below" "wod 11/3/1998: zap the organization before rather than after condensing changes." | oldCodeString argsAndTemps bTotal bCount oldMethods newMethods m | (self confirm: '-- CAUTION -- If you have backed up your system and are prepared to face the consequences of abandoning source code files, hit Yes. If you have any doubts, hit No, to back out with no harm done.') == true ifFalse: [^ self inform: 'Okay - no harm done']. Smalltalk forgetDoIts. oldMethods _ OrderedCollection new: CompiledMethod instanceCount. newMethods _ OrderedCollection new: CompiledMethod instanceCount. bTotal _ 0. bCount _ 0. self systemNavigation allBehaviorsDo: [: b | bTotal _ bTotal + 1]. 'Saving temp names for better decompilation...' displayProgressAt: Sensor cursorPoint from: 0 to: bTotal during: [:bar | Smalltalk allBehaviorsDo: "for test: (Array with: Arc with: Arc class) do: " [:cl | bar value: (bCount _ bCount + 1). cl selectors do: [:selector | m _ cl compiledMethodAt: selector. m fileIndex > 0 ifTrue: [oldCodeString _ cl sourceCodeAt: selector. argsAndTemps _ (cl compilerClass new parse: oldCodeString in: cl notifying: nil) tempNames. oldMethods addLast: m. newMethods addLast: (m copyWithTempNames: argsAndTemps)]]]]. oldMethods asArray elementsExchangeIdentityWith: newMethods asArray. self systemNavigation allBehaviorsDo: [: b | b zapOrganization]. Smalltalk condenseChanges. Preferences disable: #warnIfNoSourcesFile. " In a system with 7780 methods, we got 83k of temp names, or around 100k with spaces between. The order of letter frequency was eatrnoislcmdgpSub, with about 60k falling in the first 11. This suggests that we could encode in 4 bits, with 0-11 beng most common chars, and 12-15 contributing 2 bits to the next nibble for 6 bits, enough to cover all alphaNumeric with upper and lower case. If we get 3/4 in 4 bits and 1/4 in 8, then we get 5 bits per char, or about 38% savings (=38k in this case). Summary: about 13 bytes of temp names per method, or 8 with simple compression, plus 1 for the size. This would be 5 bytes more than the current 4-byte trailer. "! ! !SystemDictionary methodsFor: 'deprecated'! allImplementorsOf: aSelector localTo: aClass self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allImplementorsOf:localTo:'! allPrimitiveMessages self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allPrimitiveMethods'! allSelect: aBlock self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allMethodsSelect:'! allCallsOn: firstLiteral and: secondLiteral self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allCallsOn:and:'! allSentMessagesWithout: classesAndMessagesPair self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allSentMessagesWithout:'! allUnusedClassesWithout: classesAndMessagesPair self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allUnusedClassesWithout:'! allClassesImplementing: aSelector self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allClassesImplementing:'! allUnSentMessagesWithout: classesAndMessagesPair self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allUnSentMessagesWithout:'! allPrimitiveMethodsInCategories: aList self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allPrimitiveMethodsInCategories:'! allUnSentMessages self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allUnSentMessages'! allMethodsInCategory: category self flag: #deprecated. self error: 'Method Deprecated: Use ClassDescription>>allMethodsInCategory:'! allSentMessages self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allSentMessages'! allObjectsSelect: aBlock self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allObjectsSelect:'! allUnSentMessagesIn: selectorSet self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allUnSentMessagesIn:'! allMethodsWithSourceString: aString matchCase: caseSensitive self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allMethodsWithSourceString:matchCase:'! allCallsOn: aLiteral self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allCallsOn:'! allGlobalRefsWithout: classesAndMessagesPair self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allGlobalRefsWithout:'! selectorsWithAnyImplementorsIn: selectorList self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allSelectorsWithAnyImplementorsIn:'! allObjectsDo: aBlock self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allObjectsDo:'! allImplementedMessagesWithout: classesAndMessagesPair self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allImplementedMessagesWithout:'! allImplementedMessages self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allImplementedMessages'! allSelectNoDoits: aBlock self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allMethodsNoDoitsSelect:'! numberOfImplementorsOf: aSelector self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>numberOfImplementorsOf:'! allUnimplementedCalls self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allUnimplementedCalls'! isThereAnImplementorOf: aSelector self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>isThereAnImplementorOf:'! allImplementorsOf: aSelector self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allImplementorsOf:'! allGlobalRefs self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allGlobalRefs'! ! !SystemDictionary methodsFor: 'housekeeping'! verifyChanges "Smalltalk verifyChanges" "Recompile all methods in the changes file." self systemNavigation allBehaviorsDo: [:class | class recompileChanges]. ! testFormatter2 "Smalltalk testFormatter2" "Reformats the source for every method in the system, and then verifies that the order of source tokens is unchanged. The formatting used will be either classic monochrome or fancy polychrome, depending on the setting of the preference #colorWhenPrettyPrinting." | newCodeString badOnes n oldCodeString oldTokens newTokens | badOnes _ OrderedCollection new. Smalltalk forgetDoIts. 'Formatting all classes...' displayProgressAt: Sensor cursorPoint from: 0 to: CompiledMethod instanceCount during: [:bar | n _ 0. self systemNavigation allBehaviorsDo: [:cls | "Transcript cr; show: cls name." cls selectors do: [:selector | (n _ n+1) \\ 100 = 0 ifTrue: [bar value: n]. oldCodeString _ (cls sourceCodeAt: selector) asString. newCodeString _ (cls compilerClass new) format: oldCodeString in: cls notifying: nil decorated: Preferences colorWhenPrettyPrinting. oldTokens _ oldCodeString findTokens: Character separators. newTokens _ newCodeString findTokens: Character separators. oldTokens = newTokens ifFalse: [Transcript cr; show: '***' , cls name , ' ' , selector. badOnes add: cls name , ' ' , selector]]]. ]. self systemNavigation browseMessageList: badOnes asSortedCollection name: 'Formatter Discrepancies'! makeSqueaklandRelease "Smalltalk makeSqueaklandRelease" "NOTE: This method assumes that * ALL WINDOWS HAVE BEEN CLOSED (most importantly all project windows) * ALL GLOBAL FLAPS HAVE BEEN DESTROYED (not just disabled) This method may needs to be run twice - upon the first run you will probably receive an error message saying 'still have obsolete behaviors'. Close the notifier and try again. If there are still obsolete behaviors then go looking for them. Last update: ar 8/18/2001 01:14 for Squeak 3.1" | ss | (self confirm: self version , ' Is this the correct version designation? If not, choose no, and fix it.') ifFalse: [^ self]. "Delete all projects" Project allSubInstancesDo: [:p | p == Project current ifFalse: [Project deletingProject: p]]. "Fix up for some historical problem" self systemNavigation allObjectsDo: [:o | o isMorph ifTrue: [o removeProperty: #undoGrabCommand]]. "Hm ... how did this come in?!!" Smalltalk keys do: [:x | (x class == String and: [(Smalltalk at: x) isBehavior]) ifTrue: [Smalltalk removeKey: x]]. "Remove stuff from References" References keys do: [:k | References removeKey: k]. "Reset command history" CommandHistory resetAllHistory. "Clean out Undeclared" Undeclared removeUnreferencedKeys. "Reset scripting system" StandardScriptingSystem initialize. "Reset preferences" Preferences chooseInitialSettings; installBrightWindowColors. "Do a nice fat GC" Smalltalk garbageCollect. "Dependents mean that we're holding onto stuff" (Object classPool at: #DependentsFields) size > 1 ifTrue: [self error: 'Still have dependents']. "Set a few default preferences" #(#(#honorDesktopCmdKeys #false) #(#warnIfNoChangesFile #false) #(#warnIfNoSourcesFile #false) #(#showDirectionForSketches #true) #(#menuColorFromWorld #false) #(#unlimitedPaintArea #true) #(#useGlobalFlaps #false) #(#mvcProjectsAllowed #false) #(#projectViewsInWindows #false) #(#automaticKeyGeneration #true) #(#securityChecksEnabled #true) #(#showSecurityStatus #false) #(#startInUntrustedDirectory #true) #(#warnAboutInsecureContent #false) #(#promptForUpdateServer #false) #(#fastDragWindowForMorphic #false) ) do: [:spec | Preferences setPreference: spec first toValue: spec last == #true]. "Initialize Browser (e.g., reset recent classes etc)" Browser initialize. "Check for Undeclared" Undeclared isEmpty ifFalse: [self error: 'Please clean out Undeclared']. "Remove graphics we don't want" ScriptingSystem deletePrivateGraphics. "Remove a few text styles" #(#Helvetica #Palatino #Courier ) do: [:n | TextConstants removeKey: n ifAbsent: []]. "Dump all player uniclasses" Smalltalk at: #Player ifPresent: [:player | player allSubclassesDo: [:cls | cls isSystemDefined ifFalse: [cls removeFromSystem]]]. "Dump all Wonderland uniclasses" Smalltalk at: #WonderlandActor ifPresent: [:wnldActor | wnldActor allSubclassesDo: [:cls | cls isSystemDefined ifFalse: [cls removeFromSystem]]]. "Attempt to get rid of them" Smalltalk garbageCollect. "Now remove larger parts" Smalltalk discardFFI; discard3D; discardSUnit; discardSpeech; discardVMConstruction; discardPWS; discardIRC. "Dump change sets" ChangeSorter removeChangeSetsNamedSuchThat: [:cs | cs name ~= Smalltalk changes name]. "Clear current change set" Smalltalk changes clear. Smalltalk changes name: 'Unnamed1'. Smalltalk garbageCollect. "Reinitialize DataStream; it may hold on to some zapped entitities" DataStream initialize. "Remove refs to old ControlManager" ScheduledControllers _ nil. "Flush obsolete subclasses" Behavior flushObsoleteSubclasses. Smalltalk garbageCollect. Smalltalk obsoleteBehaviors isEmpty ifFalse: [self error: 'Still have obsolete behaviors']. "Clear all server entries" ServerDirectory serverNames do: [:each | ServerDirectory removeServerNamed: each]. SystemVersion current resetHighestUpdate. ss _ Set allSubInstances. 'Rehashing all sets' displayProgressAt: Sensor cursorPoint from: 1 to: ss size during: [:bar | 1 to: ss size do: [:i | bar value: i. (ss at: i) rehash]]. Smalltalk obsoleteClasses isEmpty ifFalse: [self halt]. self halt: 'Ready to condense changes or sources'. SystemDictionary removeSelector: #makeSqueaklandRelease! testDecompiler "Smalltalk testDecompiler" "Decompiles the source for every method in the system, and then compiles that source and verifies that it generates (and decompiles to) identical code. This currently fails in a number of places because some different patterns (esp involving conditionals where the first branch returns) decompile the same." | methodNode oldMethod newMethod badOnes oldCodeString n | badOnes _ OrderedCollection new. Smalltalk forgetDoIts. 'Decompiling all classes...' displayProgressAt: Sensor cursorPoint from: 0 to: CompiledMethod instanceCount during: [:bar | n _ 0. self systemNavigation allBehaviorsDo: [:cls | "Transcript cr; show: cls name." cls selectors do: [:selector | (n _ n+1) \\ 100 = 0 ifTrue: [bar value: n]. oldMethod _ cls compiledMethodAt: selector. oldCodeString _ (cls decompilerClass new decompile: selector in: cls method: oldMethod) decompileString. methodNode _ cls compilerClass new compile: oldCodeString in: cls notifying: nil ifFail: []. newMethod _ methodNode generate: #(0 0 0 0). oldCodeString = (cls decompilerClass new decompile: selector in: cls method: newMethod) decompileString ifFalse: [Transcript cr; show: '***' , cls name , ' ' , selector. badOnes add: cls name , ' ' , selector]]]. ]. self systemNavigation browseMessageList: badOnes asSortedCollection name: 'Decompiler Discrepancies'! removeAllLineFeeds "Smalltalk removeAllLineFeeds" "Scan all methods for source code with lineFeeds. Replaces all occurrences of by , noted by beep. Halts with a message if any other LFs are found." | oldCodeString n crlf cr newCodeString oldStamp oldCategory m | crlf _ String with: Character cr with: Character lf. cr _ String with: Character cr. Smalltalk forgetDoIts. 'Scanning sources for LineFeeds. This will take a few minutes...' displayProgressAt: Sensor cursorPoint from: 0 to: CompiledMethod instanceCount during: [:bar | n _ 0. m _ 0. self systemNavigation allBehaviorsDo: [:cls | cls selectors do: [:selector | (n _ n+1) \\ 100 = 0 ifTrue: [bar value: n]. oldCodeString _ (cls sourceCodeAt: selector) asString. (oldCodeString indexOf: Character lf startingAt: 1) > 0 ifTrue: [self beep. newCodeString _ oldCodeString copyReplaceAll: crlf with: cr asTokens: false. (newCodeString indexOf: Character lf startingAt: 1) > 0 ifTrue: [(self confirm: cls name , ' ' , (selector contractTo: 30) , ' has an isolated LineFeed (not part of CRLF). Shall I replace it?') ifFalse: [self halt]]. oldStamp _ Utilities timeStampForMethod: (cls compiledMethodAt: selector). oldCategory _ cls whichCategoryIncludesSelector: selector. cls compile: newCodeString classified: oldCategory withStamp: oldStamp notifying: nil. m _ m + 1]]]. ]. Transcript cr; show: m printString , ' methods stripped of LFs.'. ! forgetDoIts "Smalltalk forgetDoIts" "get rid of old DoIt methods" self systemNavigation allBehaviorsDo: [:cl | cl forgetDoIts] ! obsoleteBehaviors "Smalltalk obsoleteBehaviors inspect" "Find all obsolete behaviors including meta classes" | obs | obs _ OrderedCollection new. Smalltalk garbageCollect. self systemNavigation allObjectsDo: [:cl | (cl isBehavior and: [cl isObsolete]) ifTrue: [obs add: cl]]. ^ obs asArray! testFormatter "Smalltalk testFormatter" "Reformats the source for every method in the system, and then compiles that source and verifies that it generates identical code. The formatting used will be either classic monochrome or fancy polychrome, depending on the setting of the preference #colorWhenPrettyPrinting." | newCodeString methodNode oldMethod newMethod badOnes n | badOnes _ OrderedCollection new. Smalltalk forgetDoIts. 'Formatting all classes...' displayProgressAt: Sensor cursorPoint from: 0 to: CompiledMethod instanceCount during: [:bar | n _ 0. self systemNavigation allBehaviorsDo: [:cls | "Transcript cr; show: cls name." cls selectors do: [:selector | (n _ n+1) \\ 100 = 0 ifTrue: [bar value: n]. newCodeString _ (cls compilerClass new) format: (cls sourceCodeAt: selector) in: cls notifying: nil decorated: Preferences colorWhenPrettyPrinting. methodNode _ cls compilerClass new compile: newCodeString in: cls notifying: nil ifFail: []. newMethod _ methodNode generate: #(0 0 0 0). oldMethod _ cls compiledMethodAt: selector. oldMethod = newMethod ifFalse: [Transcript cr; show: '***' , cls name , ' ' , selector. badOnes add: cls name , ' ' , selector]]]. ]. self systemNavigation browseMessageList: badOnes asSortedCollection name: 'Formatter Discrepancies'! macroBenchmark1 "Smalltalk macroBenchmark1" "Decompiles and prettyPrints the source for every method in the system (or less depending on the *FILTER*, and then compiles that source and verifies that it generates (and decompiles to) identical code. This currently fails in a number of places because some different patterns (esp involving conditionals where the first branch returns) decompile the same. Because it never installs the new method, it should not cause any flusing of the method cache." | methodNode oldMethod newMethod badOnes oldCodeString n classes | classes _ self systemNavigation allClasses select: [:c | c name < 'B3']. badOnes _ OrderedCollection new. 'Decompiling and recompiling...' displayProgressAt: Sensor cursorPoint from: 0 to: (classes detectSum: [:c | c selectors size]) during: [:bar | n _ 0. classes do: [:cls | "Transcript cr; show: cls name." cls selectors do: [:selector | bar value: (n _ n + 1). oldMethod _ cls compiledMethodAt: selector. oldCodeString _ (cls decompilerClass new decompile: selector in: cls method: oldMethod) decompileString. methodNode _ cls compilerClass new compile: oldCodeString in: cls notifying: nil ifFail: []. newMethod _ methodNode generate: #(0 0 0 0 ). oldCodeString = (cls decompilerClass new decompile: selector in: cls method: newMethod) decompileString ifFalse: [badOnes add: cls name , ' ' , selector]]]]. ^ badOnes size! ! !Behavior methodsFor: 'deprecated'! allUnsentMessages "this method was not used at all, required a reference to systemNavigation and systemNavigation had the same functionality" self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allUnsentMessagesIn: instead'! ! !CodeHolder methodsFor: 'annotation'! annotationForSelector: aSelector ofClass: aClass "Provide a line of content for an annotation pane, representing information about the given selector and class" | stamp sendersCount implementorsCount aCategory separator aString aList aComment aStream requestList | aSelector == #Comment ifTrue: [^ self annotationForClassCommentFor: aClass]. aSelector == #Definition ifTrue: [^ self annotationForClassDefinitionFor: aClass]. aSelector == #Hierarchy ifTrue: [^ self annotationForHierarchyFor: aClass]. aStream _ ReadWriteStream on: ''. requestList _ self annotationRequests. separator _ requestList size > 1 ifTrue: [self annotationSeparator] ifFalse: ['']. requestList do: [:aRequest | aRequest == #firstComment ifTrue: [aComment _ aClass firstCommentAt: aSelector. aComment isEmptyOrNil ifFalse: [aStream nextPutAll: aComment , separator]]. aRequest == #masterComment ifTrue: [aComment _ aClass supermostPrecodeCommentFor: aSelector. aComment isEmptyOrNil ifFalse: [aStream nextPutAll: aComment , separator]]. aRequest == #documentation ifTrue: [aComment _ aClass precodeCommentOrInheritedCommentFor: aSelector. aComment isEmptyOrNil ifFalse: [aStream nextPutAll: aComment , separator]]. aRequest == #timeStamp ifTrue: [stamp _ self timeStamp. aStream nextPutAll: (stamp size > 0 ifTrue: [stamp , separator] ifFalse: ['no timeStamp' , separator])]. aRequest == #messageCategory ifTrue: [aCategory _ aClass organization categoryOfElement: aSelector. aCategory ifNotNil: ["woud be nil for a method no longer present, e.g. in a recent-submissions browser" aStream nextPutAll: aCategory , separator]]. aRequest == #sendersCount ifTrue: [sendersCount _ (self systemNavigation allCallsOn: aSelector) size. sendersCount _ sendersCount == 1 ifTrue: ['1 sender'] ifFalse: [sendersCount printString , ' senders']. aStream nextPutAll: sendersCount , separator]. aRequest == #implementorsCount ifTrue: [implementorsCount _ self systemNavigation numberOfImplementorsOf: aSelector. implementorsCount _ implementorsCount == 1 ifTrue: ['1 implementor'] ifFalse: [implementorsCount printString , ' implementors']. aStream nextPutAll: implementorsCount , separator]. aRequest == #priorVersionsCount ifTrue: [self addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream]. aRequest == #priorTimeStamp ifTrue: [stamp _ VersionsBrowser timeStampFor: aSelector class: aClass reverseOrdinal: 2. stamp ifNotNil: [aStream nextPutAll: 'prior time stamp: ' , stamp , separator]]. aRequest == #recentChangeSet ifTrue: [aString _ ChangeSorter mostRecentChangeSetWithChangeForClass: aClass selector: aSelector. aString size > 0 ifTrue: [aStream nextPutAll: aString , separator]]. aRequest == #allChangeSets ifTrue: [aList _ ChangeSorter allChangeSetsWithClass: aClass selector: aSelector. aList size > 0 ifTrue: [aList size = 1 ifTrue: [aStream nextPutAll: 'only in change set '] ifFalse: [aStream nextPutAll: 'in change sets: ']. aList do: [:aChangeSet | aStream nextPutAll: aChangeSet name , ' ']] ifFalse: [aStream nextPutAll: 'in no change set']. aStream nextPutAll: separator]]. ^ aStream contents! ! !CodeHolder methodsFor: 'misc'! isThereAnOverride "Answer whether any subclass of my selected class implements my selected selector" | aName aClass | aName _ self selectedMessageName ifNil: [^ false]. aClass _ self selectedClassOrMetaClass. (self systemNavigation allImplementorsOf: aName) do: [:each | (each actualClass inheritsFrom: aClass) ifTrue: [^ true]]. ^ false! ! !CodeHolder methodsFor: 'commands'! showUnreferencedClassVars "Search for all class variables known to the selected class, and put up a list of those that have no references anywhere in the system. The search includes superclasses, so that you don't need to navigate your way to the class that defines each class variable in order to determine whether it is unreferenced" | cls aList aReport | (cls _ self selectedClass) ifNil: [^ self]. aList _ self systemNavigation allUnreferencedClassVariablesOf: cls. aList size == 0 ifTrue: [^ self inform: 'There are no unreferenced class variables in ' , cls name]. aReport _ String streamContents: [:aStream | aStream nextPutAll: 'Unreferenced class variable(s) in ' , cls name; cr. aList do: [:el | aStream tab; nextPutAll: el; cr]]. Transcript cr; show: aReport. (SelectionMenu labels: aList selections: aList) startUpWithCaption: 'Unreferenced class variables in ' , cls name! ! !SyntaxMorph methodsFor: 'type checking'! allSpecs "Return all specs that the Viewer knows about. Maybe cache it." "SyntaxMorph new allSpecs" | all | all _ OrderedCollection new. (SystemNavigation new allImplementorsOf: #additionsToViewerCategories) do: [:pp | all addAll: pp actualClass additionsToViewerCategories]. ^ all! ! !SyntaxMorph class methodsFor: 'as yet unclassified'! testAllMethodsOver: methodSize "MessageTally spyOn: [SyntaxMorph testAllMethodsOver: 600]" "Add up the total layout area for syntax morphs representing all methods over the given size. This is a stress-test for SyntaxMorph layout. A small value for the total area is also a figure of merit in the presentation of Squeak source code in general." "Results: #(69 600 180820874 103700) 11/4 70% build morphs, 12% get source, 9% layout, 8% parse, 1% roundoff Folded wide receivers, don't center keywords any more. #(68 600 160033784 127727) 11/9 76% build morphs, 8% get source, 8% layout, 8% parse, 0% roundoff Folded more messages, dropped extra vertical spacing in blocks. #(68 600 109141704 137308) 11/10 79% build morphs, 6% get source, 8% layout, 7% parse Folded more messages, dropped extra horizontal spacing. #(68 600 106912968 132171) 11/10 80% build morphs, ??% get source, 11% layout, 7% parse Unfolded keyword messages that will fit on one line. #(68 600 96497372 132153) 11/10 81% build morphs, ??% get source, 8% layout, 8% parse After alignment rewrite... #(74 600 101082316 244799) 11/12 76% build morphs, 4% get source, 15% layout, 5% parse After alignment rewrite... #(74 600 101250620 204972) 11/15 74% build morphs, 6% get source, 13% layout, 7% parse " | tree source biggies morph stats time area | biggies _ SystemNavigation new allMethodsSelect: [:cm | cm size > methodSize]. stats _ OrderedCollection new. 'Laying out all ' , biggies size printString , ' methods over ' , methodSize printString , ' bytes...' displayProgressAt: Sensor cursorPoint from: 1 to: biggies size during: [:bar | biggies withIndexDo: [:methodRef :i | bar value: i. Utilities setClassAndSelectorFrom: methodRef in: [:aClass :aSelector | source _ (aClass compiledMethodAt: aSelector) getSourceFromFile. time _ Time millisecondsToRun: [tree _ Compiler new parse: source in: aClass notifying: nil. morph _ tree asMorphicSyntaxUsing: SyntaxMorph. area _ morph fullBounds area]]. stats add: {methodRef. area. time}]]. ^ {{biggies size. methodSize. stats detectSum: [:a | a second]. stats detectSum: [:a | a third]}. (stats asSortedCollection: [:x :y | x third >= y third]) asArray}! testAll | source tree total count systNav| " SyntaxMorph testAll " systNav _ SystemNavigation new. count _ total _ 0. systNav allBehaviorsDo: [ :aClass | total _ total + 1]. 'Testing all behaviors' displayProgressAt: Sensor cursorPoint from: 0 to: total during: [ :bar | systNav allBehaviorsDo: [ :aClass | bar value: (count _ count + 1). aClass selectors do: [ :aSelector | source _ (aClass compiledMethodAt: aSelector) getSourceFromFile. tree _ Compiler new parse: source in: aClass notifying: nil. tree asMorphicSyntaxUsing: SyntaxMorph. ]. ]. ]. ! ! "Change Set: KCP-0050-mvAllCallSystemDict Date: 18 April 2003 Author: stephane ducasse Move all the query methods from SystemDictionary to SystemNavigation. Still I'm not completely happy with the solution because the design should support multiple namespace or environment. So systemNavigation has allClasses to get all the class and SystemDictionary to get the classes currently defined in a systemDictionary. This means that all the senders of allClasses will have to be evaluated to know whether they work at a global level or a systemDictionary level. "!