'From Squeak3.5 of ''11 April 2003'' [latest update: #5180] on 29 April 2003 at 9:23:51 pm'! "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. "! !Behavior methodsFor: 'deprecated' stamp: 'sd 4/29/2003 20:25'! 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'! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'sd 4/29/2003 20:19'! 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! ! !ClassDescription methodsFor: 'method dictionary' stamp: 'sd 4/18/2003 10:26'! 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"! ! !ClassDescription methodsFor: 'deprecated' stamp: 'sd 4/29/2003 13:10'! allUnreferencedClassVariables self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allUnreferencedClassVariablesOf: instead'! ! !ClassOrganizer methodsFor: 'systemNavigation' stamp: 'sd 4/17/2003 20:44'! systemNavigation ^ SystemNavigation new! ! !ClassOrganizer methodsFor: 'fileIn/Out' stamp: 'sd 4/17/2003 20:44'! 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" ! ! !CompiledMethod methodsFor: 'printing' stamp: 'sd 4/17/2003 20:45'! 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 ! ! !Dictionary methodsFor: 'removing' stamp: 'sd 4/29/2003 12:01'! 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]]! ! !EToyVocabulary methodsFor: 'initialization' stamp: 'sd 4/19/2003 12:16'! 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"! ! !LookupKey methodsFor: 'bindings' stamp: 'sd 4/29/2003 12:17'! 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]]! ! !Morph methodsFor: 'naming' stamp: 'sd 4/29/2003 12:00'! 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! ! !CipherPanel class methodsFor: 'as yet unclassified' stamp: 'sd 4/17/2003 21:20'! randomComment "CipherPanel randomComment" "Generate cryptic puzzles from method comments in the system" | c s | s _ 'none'. [s = 'none'] whileTrue: [s _ ((c _ SystemNavigation new allClasses atRandom) selectors collect: [:sel | (c firstCommentAt: sel) asString]) detect: [:str | str size between: 100 and: 200] ifNone: ['none']]. ^ s! ! !ParagraphEditor methodsFor: 'explain' stamp: 'sd 4/17/2003 20:47'! 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! ! !ParagraphEditor methodsFor: 'explain' stamp: 'sd 4/17/2003 20:50'! 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 , '"'! ! !PositionableStream methodsFor: 'fileIn/Out' stamp: 'sd 4/17/2003 20:53'! 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! ! !StringHolder methodsFor: 'message list menu' stamp: 'sd 4/29/2003 20:20'! 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! ! !CodeHolder methodsFor: 'annotation' stamp: 'sd 4/29/2003 11:54'! 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: 'commands' stamp: 'sd 4/29/2003 13:09'! 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! ! !CodeHolder methodsFor: 'misc' stamp: 'sd 4/19/2003 12:12'! 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! ! !Browser methodsFor: 'class functions' stamp: 'sd 4/29/2003 11:49'! 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]! ! !ClassListBrowser class methodsFor: 'examples' stamp: 'sd 4/17/2003 21:21'! 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' stamp: 'sd 4/17/2003 21:21'! 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' stamp: 'sd 4/29/2003 12:24'! filterToUnsentMessages "Filter the receiver's list down to only those items which have no senders" self filterFrom: [:aClass :aSelector | (self systemNavigation allCallsOn: aSelector) isEmpty]! ! !Lexicon methodsFor: 'category list' stamp: 'sd 4/29/2003 12:15'! 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! ! !Lexicon methodsFor: 'senders' stamp: 'sd 4/29/2003 12:15'! 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]! ! !Lexicon methodsFor: 'senders' stamp: 'sd 4/29/2003 12:16'! 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! ! !Lexicon methodsFor: 'senders' stamp: 'sd 4/29/2003 12:16'! 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]! ! !MessageNames methodsFor: 'search' stamp: 'sd 4/20/2003 14:28'! 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! ! !MessageNames methodsFor: 'search' stamp: 'sd 4/20/2003 14:28'! 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]]! ! !MessageNames methodsFor: 'selector list' stamp: 'sd 4/19/2003 12:12'! 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! ! !SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'sd 4/19/2003 12:13'! 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! ! !Symbol class methodsFor: 'class initialization' stamp: 'sd 4/19/2003 12:13'! 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'! ! !SyntaxMorph methodsFor: 'type checking' stamp: 'sd 4/19/2003 12:15'! 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' stamp: 'sd 4/17/2003 20:54'! 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. ]. ]. ]. ! ! !SyntaxMorph class methodsFor: 'as yet unclassified' stamp: 'sd 4/29/2003 20:43'! 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}! ! !SystemDictionary methodsFor: 'deprecated' stamp: 'sd 4/17/2003 19:22'! allBehaviorsDo: aBlock self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allBehaviorsDo:'! ! !SystemDictionary methodsFor: 'deprecated' stamp: 'sd 4/29/2003 11:49'! allCallsOn: aLiteral self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allCallsOn:'! ! !SystemDictionary methodsFor: 'deprecated' stamp: 'sd 4/17/2003 21:14'! allCallsOn: firstLiteral and: secondLiteral self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allCallsOn:and:'! ! !SystemDictionary methodsFor: 'deprecated' stamp: 'sd 4/17/2003 21:19'! allClassesImplementing: aSelector self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allClassesImplementing:'! ! !SystemDictionary methodsFor: 'deprecated' stamp: 'sd 4/18/2003 10:04'! allGlobalRefs self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allGlobalRefs'! ! !SystemDictionary methodsFor: 'deprecated' stamp: 'sd 4/29/2003 13:23'! allGlobalRefsWithout: classesAndMessagesPair self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allGlobalRefsWithout:'! ! !SystemDictionary methodsFor: 'deprecated' stamp: 'sd 4/29/2003 13:25'! allImplementedMessages self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allImplementedMessages'! ! !SystemDictionary methodsFor: 'deprecated' stamp: 'sd 4/29/2003 13:31'! allImplementedMessagesWithout: classesAndMessagesPair self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allImplementedMessagesWithout:'! ! !SystemDictionary methodsFor: 'deprecated' stamp: 'sd 4/20/2003 14:15'! allImplementorsOf: aSelector self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allImplementorsOf:'! ! !SystemDictionary methodsFor: 'deprecated' stamp: 'sd 4/20/2003 14:15'! allImplementorsOf: aSelector localTo: aClass self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allImplementorsOf:localTo:'! ! !SystemDictionary methodsFor: 'deprecated' stamp: 'sd 4/18/2003 10:30'! allMethodsInCategory: category self flag: #deprecated. self error: 'Method Deprecated: Use ClassDescription>>allMethodsInCategory:'! ! !SystemDictionary methodsFor: 'deprecated' stamp: 'sd 4/20/2003 14:11'! allMethodsWithSourceString: aString matchCase: caseSensitive self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allMethodsWithSourceString:matchCase:'! ! !SystemDictionary methodsFor: 'deprecated' stamp: 'sd 4/29/2003 20:54'! allObjectsDo: aBlock self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allObjectsDo:'! ! !SystemDictionary methodsFor: 'deprecated' stamp: 'sd 4/29/2003 20:56'! allObjectsSelect: aBlock self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allObjectsSelect:'! ! !SystemDictionary methodsFor: 'deprecated' stamp: 'sd 4/20/2003 14:23'! allPrimitiveMessages self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allPrimitiveMethods'! ! !SystemDictionary methodsFor: 'deprecated' stamp: 'sd 4/20/2003 14:20'! allPrimitiveMethodsInCategories: aList self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allPrimitiveMethodsInCategories:'! ! !SystemDictionary methodsFor: 'deprecated' stamp: 'sd 4/23/2003 22:29'! allSelect: aBlock self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allMethodsSelect:'! ! !SystemDictionary methodsFor: 'deprecated' stamp: 'sd 4/29/2003 20:42'! allSelectNoDoits: aBlock self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allMethodsNoDoitsSelect:'! ! !SystemDictionary methodsFor: 'deprecated' stamp: 'sd 4/29/2003 20:13'! allSentMessages self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allSentMessages'! ! !SystemDictionary methodsFor: 'deprecated' stamp: 'sd 4/29/2003 19:12'! allSentMessagesWithout: classesAndMessagesPair self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allSentMessagesWithout:'! ! !SystemDictionary methodsFor: 'deprecated' stamp: 'sd 4/29/2003 20:13'! allUnSentMessages self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allUnSentMessages'! ! !SystemDictionary methodsFor: 'deprecated' stamp: 'sd 4/29/2003 20:14'! allUnSentMessagesIn: selectorSet self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allUnSentMessagesIn:'! ! !SystemDictionary methodsFor: 'deprecated' stamp: 'sd 4/29/2003 19:20'! allUnSentMessagesWithout: classesAndMessagesPair self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allUnSentMessagesWithout:'! ! !SystemDictionary methodsFor: 'deprecated' stamp: 'sd 4/29/2003 19:04'! allUnimplementedCalls self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allUnimplementedCalls'! ! !SystemDictionary methodsFor: 'deprecated' stamp: 'sd 4/29/2003 19:08'! allUnusedClassesWithout: classesAndMessagesPair self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allUnusedClassesWithout:'! ! !SystemDictionary methodsFor: 'deprecated' stamp: 'sd 4/18/2003 10:45'! isThereAnImplementorOf: aSelector self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>isThereAnImplementorOf:'! ! !SystemDictionary methodsFor: 'deprecated' stamp: 'sd 4/18/2003 10:40'! numberOfImplementorsOf: aSelector self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>numberOfImplementorsOf:'! ! !SystemDictionary methodsFor: 'deprecated' stamp: 'sd 4/20/2003 14:29'! selectorsWithAnyImplementorsIn: selectorList self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allSelectorsWithAnyImplementorsIn:'! ! !SystemDictionary methodsFor: 'housekeeping' stamp: 'sd 4/17/2003 20:59'! forgetDoIts "Smalltalk forgetDoIts" "get rid of old DoIt methods" self systemNavigation allBehaviorsDo: [:cl | cl forgetDoIts] ! ! !SystemDictionary methodsFor: 'housekeeping' stamp: 'sd 4/17/2003 21:30'! 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! ! !SystemDictionary methodsFor: 'housekeeping' stamp: 'sd 4/29/2003 20:56'! 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! ! !SystemDictionary methodsFor: 'housekeeping' stamp: 'sd 4/29/2003 20:57'! 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! ! !SystemDictionary methodsFor: 'housekeeping' stamp: 'sd 4/17/2003 21:00'! 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.'. ! ! !SystemDictionary methodsFor: 'housekeeping' stamp: 'sd 4/17/2003 21:01'! 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'! ! !SystemDictionary methodsFor: 'housekeeping' stamp: 'sd 4/17/2003 21:01'! 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'! ! !SystemDictionary methodsFor: 'housekeeping' stamp: 'sd 4/17/2003 21:01'! 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'! ! !SystemDictionary methodsFor: 'housekeeping' stamp: 'sd 4/17/2003 21:01'! verifyChanges "Smalltalk verifyChanges" "Recompile all methods in the changes file." self systemNavigation allBehaviorsDo: [:class | class recompileChanges]. ! ! !SystemDictionary methodsFor: 'retrieving' stamp: 'sd 4/17/2003 21:15'! allClasses "Return all the class defines in the Smalltalk SystemDictionary" "Smalltalk allClasses" ^ self classNames collect: [:name | self at: name]! ! !SystemDictionary methodsFor: 'retrieving' stamp: 'sd 4/17/2003 21:18'! allClassesDo: aBlock "Evaluate the argument, aBlock, for each class in the system." (self classNames collect: [:name | self at: name]) do: aBlock! ! !SystemDictionary methodsFor: 'retrieving' stamp: 'sd 4/17/2003 21:29'! 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! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'sd 4/17/2003 20:54'! 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: 'shrinking' stamp: 'sd 4/17/2003 20:56'! 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. ! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'sd 4/29/2003 20:16'! 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! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'sd 4/29/2003 19:06'! 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: {{}. {}}! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'sd 4/29/2003 19:07'! 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}}! ! !Environment class methodsFor: 'system conversion' stamp: 'sd 4/17/2003 21:32'! 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! ! !SystemNavigation methodsFor: 'browse' stamp: 'sd 4/29/2003 12:23'! 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! ! !SystemNavigation methodsFor: 'browse' stamp: 'sd 4/19/2003 12:15'! 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! ! !SystemNavigation methodsFor: 'browse' stamp: 'sd 4/19/2003 12:15'! 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! ! !SystemNavigation methodsFor: 'browse' stamp: 'sd 4/29/2003 20:43'! 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'! ! !SystemNavigation methodsFor: 'browse' stamp: 'sd 4/29/2003 20:44'! 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! ! !SystemNavigation methodsFor: 'browse' stamp: 'sd 4/20/2003 14:11'! 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! ! !SystemNavigation methodsFor: 'query' stamp: 'sd 4/17/2003 19:22'! 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]].! ! !SystemNavigation methodsFor: 'query' stamp: 'sd 4/29/2003 11:48'! 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! ! !SystemNavigation methodsFor: 'query' stamp: 'sd 4/18/2003 08:21'! 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! ! !SystemNavigation methodsFor: 'query' stamp: 'sd 4/17/2003 21:31'! 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 ! ! !SystemNavigation methodsFor: 'query' stamp: 'sd 4/17/2003 21:31'! 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 ! ! !SystemNavigation methodsFor: 'query' stamp: 'sd 4/17/2003 21:18'! 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! ! !SystemNavigation methodsFor: 'query' stamp: 'sd 4/18/2003 10:04'! 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: {{}. {}}! ! !SystemNavigation methodsFor: 'query' stamp: 'sd 4/29/2003 18:55'! 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! ! !SystemNavigation methodsFor: 'query' stamp: 'sd 4/29/2003 13:30'! allImplementedMessages "Answer a Set of all the messages that are implemented in the system." ^ self allImplementedMessagesWithout: {{}. {}}! ! !SystemNavigation methodsFor: 'query' stamp: 'sd 4/29/2003 18:55'! 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! ! !SystemNavigation methodsFor: 'query' stamp: 'sd 4/23/2003 22:31'! 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! ! !SystemNavigation methodsFor: 'query' stamp: 'sd 4/20/2003 14:14'! 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! ! !SystemNavigation methodsFor: 'query' stamp: 'sd 4/29/2003 20:42'! 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! ! !SystemNavigation methodsFor: 'query' stamp: 'sd 4/29/2003 20:41'! 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! ! !SystemNavigation methodsFor: 'query' stamp: 'sd 4/20/2003 14:11'! 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! ! !SystemNavigation methodsFor: 'query' stamp: 'sd 4/29/2003 20:53'! 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]! ! !SystemNavigation methodsFor: 'query' stamp: 'sd 4/29/2003 20:53'! 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]]]! ! !SystemNavigation methodsFor: 'query' stamp: 'sd 4/20/2003 14:23'! 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: 'query' stamp: 'sd 4/20/2003 14:20'! 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! ! !SystemNavigation methodsFor: 'query' stamp: 'sd 4/20/2003 14:28'! 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) "! ! !SystemNavigation methodsFor: 'query' stamp: 'sd 4/29/2003 20:12'! allSentMessages "Answer the set of selectors which are sent somewhere in the system." ^ self allSentMessagesWithout: {{}. {}}! ! !SystemNavigation methodsFor: 'query' stamp: 'sd 4/29/2003 19:10'! 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! ! !SystemNavigation methodsFor: 'query' stamp: 'sd 4/29/2003 20:12'! 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: {{}. {}}! ! !SystemNavigation methodsFor: 'query' stamp: 'sd 4/29/2003 20:13'! allUnSentMessagesIn: selectorSet "Answer the subset of selectorSet which are not sent anywhere in the system. " ^ selectorSet copyWithoutAll: self allSentMessages! ! !SystemNavigation methodsFor: 'query' stamp: 'sd 4/29/2003 19:19'! 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)! ! !SystemNavigation methodsFor: 'query' stamp: 'sd 4/29/2003 18:54'! 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! ! !SystemNavigation methodsFor: 'query' stamp: 'sd 4/29/2003 13:07'! 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! ! !SystemNavigation methodsFor: 'query' stamp: 'sd 4/29/2003 19:06'! 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]]! ! !SystemNavigation methodsFor: 'query' stamp: 'sd 4/18/2003 10:44'! 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! ! !SystemNavigation methodsFor: 'query' stamp: 'sd 4/20/2003 14:27'! 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! ! !SystemNavigation methodsFor: 'query' stamp: 'sd 4/29/2003 15:17'! 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! ! !SystemNavigation methodsFor: 'query' stamp: 'sd 4/29/2003 15:17'! 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! ! !SystemNavigation methodsFor: 'ui' stamp: 'sd 4/29/2003 11:59'! 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! ! !SystemTracer methodsFor: 'initialization' stamp: 'sd 4/17/2003 21:02'! initDict writeDict _ Dictionary new: 256. Smalltalk allClassesDo: [:class | class isBits ifTrue: [writeDict at: class put: (class isBytes ifTrue: [#writeBytes:] ifFalse: [#writeWords:])] ifFalse: [writeDict at: class put: #writePointers:. (class inheritsFrom: Set) | (class == Set) ifTrue: [writeDict at: class put: #writeSet:]. (class inheritsFrom: IdentitySet) | (class == IdentitySet) ifTrue: [writeDict at: class put: #writeIdentitySet:]. (class inheritsFrom: IdentityDictionary) | (class == IdentityDictionary) ifTrue: [writeDict at: class put: #writeIdentitySet:]. (class inheritsFrom: MethodDictionary) | (class == MethodDictionary) ifTrue: [writeDict at: class put: #writeMethodDictionary:]]. ]. "check for Associations of replaced classes" writeDict at: Association put: #writeAssociation:. self systemNavigation allBehaviorsDo: [:class | writeDict at: class class put: #writeBehavior:]. writeDict at: PseudoContext class put: #writeBehavior:. writeDict at: SmallInteger put: #writeClamped:. writeDict at: CompiledMethod put: #writeMethod:. writeDict at: Process put: #writeProcess:. writeDict at: MethodContext put: #writeContext:. writeDict at: BlockContext put: #writeContext:.! ! !TestViaMethodCall class methodsFor: 'system navigation' stamp: 'sd 4/19/2003 12:17'! systemNavigation ^ SystemNavigation new! ! !TestViaMethodCall class methodsFor: 'as yet unclassified' stamp: 'sd 4/19/2003 12:17'! addClassesTo: aList "Add names of classes that have tests to perform" (self systemNavigation allImplementorsOf: #exampleFor:) do: [:mr | mr classIsMeta ifTrue: [aList add: mr classSymbol , ' (simple)']]. ^ aList! ! !TestViaMethodCall class methodsFor: 'as yet unclassified' stamp: 'sd 4/19/2003 12:17'! buildSuiteFromLocalSelectors "Return a list of tests to perform" | ts | ts _ TestSuite new name: 'From Many Classes'. (self systemNavigation allImplementorsOf: #exampleFor:) do: [:mr | mr classIsMeta ifTrue: [((Smalltalk at: mr classSymbol) exampleFor: 'all') do: [:aVerifier | ts addTest: (self new verifier: aVerifier)]]]. ^ ts! ! !Utilities class methodsFor: 'investigations' stamp: 'sd 4/29/2003 11:59'! 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: 'identification' stamp: 'sd 4/17/2003 21:03'! 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: 'miscellaneous' stamp: 'sd 4/17/2003 21:04'! 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"' ! ! !Utilities class methodsFor: 'miscellaneous' stamp: 'sd 4/17/2003 21:04'! 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"' ! ! !Vocabulary class methodsFor: 'queries' stamp: 'sd 4/19/2003 12:18'! 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! ! SystemNavigation removeSelector: #allClassesInSmalltalk! SystemNavigation removeSelector: #allClassesInSmalltalkDo:! SystemNavigation removeSelector: #allMethodsInCategory:! SystemNavigation removeSelector: #allMethodsSelectNoDoits:! SystemNavigation removeSelector: #allPrimitiveMessages! SystemNavigation removeSelector: #selectorsWithAnyImplementorsIn:! SystemDictionary removeSelector: #findNamesLikeGeorge:!