'From Squeak3.6beta of ''4 July 2003'' [latest update: #5395] on 23 August 2003 at 12:31:44 pm'! "Change Set: KCP-0100-FixSingletonReferences Date: 23 August 2003 Author: Stef and Daniel Fix all the references to SystemNavigation new to use the Object>>systemNavigation"! !CompiledMethod methodsFor: 'printing' stamp: 'dvf 8/23/2003 11:50'! who "Answer an Array of the class in which the receiver is defined and the selector to which it corresponds." | sel | self systemNavigation allBehaviorsDo: [:class | (sel := class methodDict keyAtIdentityValue: self ifAbsent: [nil]) ifNotNil: [^Array with: class with: sel]]. ^Array with: #unknown with: #unknown! ! !DeepCopier methodsFor: 'like fullCopy' stamp: 'dvf 8/23/2003 11:52'! checkDeep "Write exceptions in the Transcript. Every class that implements veryDeepInner: must copy all its inst vars. Danger is that a user will add a new instance variable and forget to copy it. This check is only run by hand once in a while to make sure nothing was forgotten. (Please do not remove this method.) DeepCopier new checkDeep " | mm | Transcript cr; show: 'Instance variables shared with the original object when it is copied'. (self systemNavigation allClassesImplementing: #veryDeepInner:) do: [:aClass | (mm := aClass instVarNames size) > 0 ifTrue: [aClass instSize - mm + 1 to: aClass instSize do: [:index | ((aClass compiledMethodAt: #veryDeepInner:) writesField: index) ifFalse: [Transcript cr; show: aClass name; space; show: (aClass allInstVarNames at: index)]]]]! ! !DeepCopier methodsFor: 'like fullCopy' stamp: 'dvf 8/23/2003 11:53'! checkVariables "Check that no indexes of instance vars have changed in certain classes. If you get an error in this method, an implementation of veryDeepCopyWith: needs to be updated. The idea is to catch a change while it is still in the system of the programmer who made it. DeepCopier new checkVariables " | meth | self checkBasicClasses. "Every class that implements veryDeepInner: must copy all its inst vars. Danger is that a user will add a new instance variable and forget to copy it. So check that the last one is mentioned in the copy method." (self systemNavigation allClassesImplementing: #veryDeepInner:) do: [:aClass | ((aClass compiledMethodAt: #veryDeepInner:) writesField: aClass instSize) ifFalse: [aClass instSize > 0 ifTrue: [self warnIverNotCopiedIn: aClass sel: #veryDeepInner:]]]. (self systemNavigation allClassesImplementing: #veryDeepCopyWith:) do: [:aClass | meth := aClass compiledMethodAt: #veryDeepCopyWith:. meth size > 20 & (meth literals includes: #veryDeepCopyWith:) not ifTrue: [(meth writesField: aClass instSize) ifFalse: [self warnIverNotCopiedIn: aClass sel: #veryDeepCopyWith:]]]! ! !DialectParser class methodsFor: 'as yet unclassified' stamp: 'dvf 8/23/2003 12:17'! test "DialectParser test" "PrettyPrints the source for every method in the system in the alternative syntax, and then compiles that source and verifies that it generates identical code. No changes are actually made to the system. At the time of this writing, only two methods caused complaints (reported in Transcript and displayed in browse window after running): BalloonEngineSimulation circleCosTable and BalloonEngineSimulation circleSinTable. These are not errors, but merely a case of Floats embedded in literal arrays, and thus not specially checked for roundoff errors. Note that if an error or interruption occurs during execution of this method, the alternativeSyntax preference will be left on. NOTE: Some methods may not compare properly until the system has been recompiled once. Do this by executing... Smalltalk recompileAllFrom: 'AARDVAARK'. " | newCodeString methodNode oldMethod newMethod badOnes n heading | Preferences enable: #printAlternateSyntax. badOnes _ OrderedCollection new. Transcript clear. Smalltalk forgetDoIts. 'Formatting and recompiling all classes...' displayProgressAt: Sensor cursorPoint from: 0 to: CompiledMethod instanceCount during: [:bar | n _ 0. Smalltalk allClassesDo: "{MethodNode} do:" "<- to check one class" [:nonMeta | "Transcript cr; show: nonMeta name." {nonMeta. nonMeta class} do: [:cls | 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. heading _ cls organization categoryOfElement: selector. methodNode _ cls compilerClass new compile: newCodeString in: cls notifying: (SyntaxError new category: heading) ifFail: []. newMethod _ methodNode generate: #(0 0 0 0). oldMethod _ cls compiledMethodAt: selector. "Transcript cr; show: cls name , ' ' , selector." oldMethod = newMethod ifFalse: [Transcript cr; show: '***' , cls name , ' ' , selector. oldMethod size = newMethod size ifFalse: [Transcript show: ' difft size']. oldMethod header = newMethod header ifFalse: [Transcript show: ' difft header']. oldMethod literals = newMethod literals ifFalse: [Transcript show: ' difft literals']. Transcript endEntry. badOnes add: cls name , ' ' , selector]]]]. ]. self systemNavigation browseMessageList: badOnes asSortedCollection name: 'Formatter Discrepancies'. Preferences disable: #printAlternateSyntax. ! ! !Dictionary methodsFor: 'removing' stamp: 'dvf 8/23/2003 11:51'! 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). (self systemNavigation allCallsOn: (self associationAt: key)) isEmpty]]! ! !EToyVocabulary methodsFor: 'initialization' stamp: 'dvf 8/23/2003 11:52'! morphClassesDeclaringViewerAdditions "Answer a list of actual morph classes implementing #additionsToViewerCategories " | survivors | survivors := OrderedCollection new. (self systemNavigation allImplementorsOf: #additionsToViewerCategories) do: [:aMarker | (aMarker actualClass isMeta and: [aMarker actualClass soleInstance isKindOf: Morph class]) ifTrue: [survivors add: aMarker actualClass soleInstance]]. ^survivors "EToyVocabulary basicNew morphClassesDeclaringViewerAdditions"! ! !FileList class methodsFor: 'class initialization' stamp: 'dvf 8/23/2003 12:17'! initialize "FileList initialize" RecentDirs := OrderedCollection new. (self systemNavigation allClassesImplementing: #fileReaderServicesForFile:suffix:) do: [:providerMetaclass | self registerFileReader: providerMetaclass soleInstance]! ! !LookupKey methodsFor: 'bindings' stamp: 'dvf 8/23/2003 11:50'! recompileBindingsAnnouncing: aBool "Make the receiver (a global read-write binding) be a read-only binding" aBool ifTrue: [Utilities informUserDuring: [:bar | (self systemNavigation allCallsOn: self) do: [:mref | bar value: 'Recompiling ' , mref asStringOrText. mref actualClass recompile: mref methodSymbol]]] ifFalse: [(self systemNavigation allCallsOn: self) do: [:mref | mref actualClass recompile: mref methodSymbol]]! ! !Morph methodsFor: 'testing' stamp: 'dvf 8/23/2003 11:50'! 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 := (self systemNavigation 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! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'dvf 8/23/2003 11:51'! classNamesContainingIt "Open a browser on classes whose names contain the selected string" self lineSelectAndEmptyCheck: [^self]. self systemNavigation browseClassesWithNamesContaining: self selection string caseSensitive: Sensor leftShiftDown! ! !PositionableStream methodsFor: 'fileIn/Out' stamp: 'dvf 8/23/2003 11:54'! 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" self systemNavigation allBehaviorsDo: [:cl | cl removeSelectorSimply: #DoIt; removeSelectorSimply: #DoItIn:]. ^val! ! !Preference methodsFor: 'menu' stamp: 'dvf 8/23/2003 12:18'! offerPreferenceNameMenu: aPanel with: ignored1 in: ignored2 "the user clicked on a preference name -- put up a menu" | aMenu | ActiveHand showTemporaryCursor: nil. aMenu _ MenuMorph new defaultTarget: self. aMenu addTitle: name. (Preferences okayToChangeProjectLocalnessOf: name) ifTrue: [aMenu addUpdating: #isProjectLocalString target: self action: #toggleProjectLocalness. aMenu balloonTextForLastItem: 'Some preferences are best applied uniformly to all projects, and others are best set by each individual project. If this item is checked, then this preference will be printed in bold and will have a separate value for each project']. aMenu add: 'browse senders' target: self systemNavigation selector: #browseAllCallsOn: argument: name. aMenu balloonTextForLastItem: 'This will open a method-list browser on all methods that the send the preference "', name, '".'. aMenu add: 'show category...' target: aPanel selector: #findCategoryFromPreference: argument: name. aMenu balloonTextForLastItem: 'Allows you to find out which category, or categories, this preference belongs to.'. Smalltalk isMorphic ifTrue: [aMenu add: 'hand me a button for this preference' target: self selector: #tearOffButton. aMenu balloonTextForLastItem: 'Will give you a button that governs this preference, which you may deposit wherever you wish']. aMenu add: 'copy this name to clipboard' target: self selector: #copyName. aMenu balloonTextForLastItem: 'Copy the name of the preference to the text clipboard, so that you can paste into code somewhere'. aMenu popUpInWorld! ! !Preferences class methodsFor: 'window colors' stamp: 'dvf 8/23/2003 12:18'! windowColorTable "Answer a list of WindowColorSpec objects, one for each tool to be represented in the window-color panel" ^ (((self systemNavigation allClassesImplementing: #windowColorSpecification) collect: [:aClass | aClass theNonMetaClass windowColorSpecification]) asSortedCollection: [:specOne :specTwo | specOne wording < specTwo wording]) asArray "Preferences windowColorTable"! ! !SmartRefStream methodsFor: 'class changed shape' stamp: 'dvf 8/23/2003 11:52'! writeClassRenameMethod: sel was: oldName fromInstVars: oldList "The class coming is unknown. Ask the user for the existing class it maps to. If got one, write a method, and restart the obj fileIn. If none, write a dummy method and get the user to complete it later. " | tell choice newName answ code oldVer newList newVer instSel | self flag: #bobconv. tell := 'Reading an instance of ' , oldName , '. Which modern class should it translate to?'. answ := (PopUpMenu labels: 'Let me type the name now Let me think about it Let me find a conversion file on the disk') startUpWithCaption: tell. answ = 1 ifTrue: [tell := 'Name of the modern class that ' , oldName , 's should it translate to:'. choice := FillInTheBlank request: tell. "class name" choice size = 0 ifTrue: [answ := 'conversion method needed'] ifFalse: [newName := choice. answ := Smalltalk at: newName asSymbol ifAbsent: ['conversion method needed']. answ class == String ifFalse: [renamed at: oldName asSymbol put: answ name]]]. answ = 3 | (answ = 0) ifTrue: [self close. ^'conversion method needed']. answ = 2 ifTrue: [answ := 'conversion method needed']. answ = 'conversion method needed' ifTrue: [self close. newName := 'PutNewClassHere']. answ class == String ifFalse: [oldVer := self versionSymbol: (structures at: oldName). newList := (Array with: answ classVersion) , answ allInstVarNames. newVer := self versionSymbol: newList. instSel := 'convert' , oldVer , ':' , newVer , ':']. code := WriteStream on: (String new: 500). code nextPutAll: sel; cr. answ class == String ifFalse: [code cr; tab; nextPutAll: 'reshaped at: #' , oldName , ' put: #' , instSel , '.'. code cr; tab; tab; nextPutAll: '"Be sure to define that conversion method in class ' , answ name , '"']. code cr; tab; nextPutAll: '^ ' , newName. "Return new class" self class compile: code contents classified: 'conversion'. newName = 'PutNewClassHere' ifTrue: [self inform: 'Please complete the following method and then read-in the object file again.'. self systemNavigation browseAllImplementorsOf: sel asSymbol]. self flag: #violateBasicLayerPrinciples. "SmartRefStream should not refer to UI!!!!!!!!!! (sd)" "The class version number only needs to change under one specific circumstance. That is when the first letters of the instance variables have stayed the same, but their meaning has changed. A conversion method is needed, but this system does not know it. If this is true for class Foo, define classVersion in Foo class. Beware of previous object fileouts already written after the change in meaning, but before bumping the version number. They have the old (wrong) version number, say 2. If this is true, your method must be able to test the data and successfully read files that say version 2 but are really 3." ^answ! ! !SmartRefStream class methodsFor: 'as yet unclassified' stamp: 'dvf 8/23/2003 12:18'! cleanUpCategories | list valid removed newList newVers | "Look for all conversion methods that can't be used any longer. Delete them." " SmartRefStream cleanUpCategories " "Two part selectors that begin with convert and end with a digit." "convertasossfe0: varDict asossfeu0: smartRefStrm" list _ Symbol selectorsContaining: 'convert'. list _ list select: [:symb | (symb beginsWith: 'convert') & (symb allButLast last isDigit) ifTrue: [(symb numArgs = 2)] ifFalse: [false]]. valid _ 0. removed _ 0. list do: [:symb | (self systemNavigation allClassesImplementing: symb) do: [:newClass | newList _ (Array with: newClass classVersion), (newClass allInstVarNames). newVers _ self new versionSymbol: newList. (symb endsWith: (':',newVers,':')) ifFalse: [ "method is useless because can't convert to current shape" newClass removeSelector: symb. "get rid of it" removed _ removed + 1] ifTrue: [valid _ valid + 1]]]. Transcript cr; show: 'Removed: '; print: removed; show: ' Kept: '; print: valid; show: ' '.! ! !Symbol class methodsFor: 'class initialization' stamp: 'dvf 8/23/2003 12:18'! 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 | self systemNavigation 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: 'dvf 8/23/2003 12:19'! allSpecs "Return all specs that the Viewer knows about. Maybe cache it." "SyntaxMorph new allSpecs" | all | all _ OrderedCollection new. (self systemNavigation allImplementorsOf: #additionsToViewerCategories) do: [:pp | all addAll: pp actualClass additionsToViewerCategories]. ^ all! ! !SyntaxMorph class methodsFor: 'as yet unclassified' stamp: 'dvf 8/23/2003 12:20'! testAll | source tree total count systNav| " SyntaxMorph testAll " systNav _ self systemNavigation. 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: 'dvf 8/23/2003 12:20'! 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 _ self systemNavigation 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}! ! !Viewer methodsFor: 'queries' stamp: 'dvf 8/23/2003 11:51'! browseSendersOf: aSelector "Open a browser on senders of aSelector" self systemNavigation browseAllCallsOn: aSelector! ! !Vocabulary class methodsFor: 'queries' stamp: 'dvf 8/23/2003 12:20'! 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 _ self systemNavigation 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! ! FileList initialize!