'From Cuis 2.6 of 10 August 2010 [latest update: #540] on 23 August 2010 at 10:24:46 pm'!

!Behavior methodsFor: 'user interface' stamp: 'jmv 8/23/2010 09:27'!
crossReference
	"Answer an Array of arrays of size 2 whose first element is a message selector in the receiver's method dictionary and whose second element is a set of all message selectors in the method dictionary whose methods send a message with that selector. Subclasses are not included."

	^self selectors asArray sort collect: [ :x |
		Array 
			with: (String with: Character cr), x 
			with: (self whichSelectorsReferTo: x) ]

	"Point crossReference."! !


!BlockNode methodsFor: 'code generation (closures)' stamp: 'jmv 8/23/2010 10:05'!
computeCopiedValues: rootNode
	| referencedValues |
	referencedValues _ rootNode referencedValuesWithinBlockExtent: blockExtent.
	^ (referencedValues reject: [ :temp |
		temp isDefinedWithinBlockExtent: blockExtent ]) asArray sort: ParseNode tempSortBlock! !


!Categorizer methodsFor: 'accessing' stamp: 'jmv 8/23/2010 09:59'!
changeFromCategorySpecs: categorySpecs 
	"Tokens is an array of categorySpecs as scanned from a browser 'reorganize' pane, or built up by some other process, such as a scan of an environment."

	| oldElements newElements newCategories newStops currentStop temp cc catSpec |
	oldElements _ elementArray asSet.
	newCategories _ Array new: categorySpecs size.
	newStops _ Array new: categorySpecs size.
	currentStop _ 0.
	newElements _ WriteStream on: (Array new: 16).
	1 to: categorySpecs size do: [ :i | 
		catSpec _ categorySpecs at: i.
		newCategories at: i put: catSpec first asSymbol.
		catSpec allButFirst asArray sort do:
			[:elem |
			(oldElements remove: elem ifAbsent: nil) ifNotNil: [
				newElements nextPut: elem.
				currentStop _ currentStop+1]].
		newStops at: i put: currentStop].

	"Ignore extra elements but don't lose any existing elements!!"
	oldElements _ oldElements collect: [ :elem | Array with: (self categoryOfElement: elem) with: elem].
	newElements _ newElements contents.
	categoryArray _ newCategories.
	(cc _ categoryArray asSet) size = categoryArray size ifFalse: [ "has duplicate element"
		temp _ categoryArray asOrderedCollection.
		temp removeAll: categoryArray asSet asOrderedCollection.
		temp do: [ :each | | dup ii |
			dup _ each.
			ii _ categoryArray indexOf: dup.
			[ dup _ (dup,' #2') asSymbol.  cc includes: dup ] whileTrue.
			cc add: dup.
			categoryArray at: ii put: dup]].
	categoryStops _ newStops.
	elementArray _ newElements.
	oldElements do: [:pair | self classify: pair last under: pair first]! !

!Categorizer methodsFor: 'accessing' stamp: 'jmv 8/23/2010 09:29'!
sortCategories
	| privateCategories publicCategories newCategories |

	privateCategories _ self categories select: [ :one |
		(one findString: 'private' startingAt: 1 caseSensitive: false) = 1].
	publicCategories _ self categories copyWithoutAll: privateCategories.
	newCategories _ publicCategories asArray sort,
		privateCategories asArray sort.
	self categories: newCategories! !


!ChangeSet methodsFor: 'fileIn/Out' stamp: 'jmv 8/23/2010 09:34'!
fileOutOn: stream 
	"Write out all the changes the receiver knows about"

	| classList |
	(self isEmpty and: [stream isKindOf: FileStream])
		ifTrue: [self inform: 'Warning: no changes to file out'].
	classList _ ChangeSet superclassOrder: self changedClasses asOrderedCollection.

	"First put out rename, max classDef and comment changes."
	classList do: [:aClass | self fileOutClassDefinition: aClass on: stream].

	"Then put out all the method changes"
	classList do: [:aClass | self fileOutChangesFor: aClass on: stream].

	"Finally put out removals, final class defs and reorganization if any"
	classList reverseDo: [:aClass | self fileOutPSFor: aClass on: stream].

	self classRemoves asArray sort do: [ :aClassName |
		stream nextChunkPut: 'Smalltalk removeClassNamed: #', aClassName; cr].! !


!ClassDescription methodsFor: 'printing' stamp: 'jmv 8/23/2010 09:36'!
classVariablesString
	"Answer a string of my class variable names separated by spaces."

	^String streamContents: [ :stream | 
		self classPool keys asArray sort 
			do: [ :each | stream nextPutAll: each ]
			separatedBy: [ stream space ] ]! !

!ClassDescription methodsFor: 'instance variables' stamp: 'jmv 8/23/2010 09:35'!
browseClassVarRefs 
	"Put up a menu offering all class variable names; if the user chooses one, open up a message-list browser on all methods that refer to the selected class variable"

	| lines labelStream allVars index owningClasses |
	lines _ OrderedCollection new.
	allVars _ OrderedCollection new.
	owningClasses _ OrderedCollection new.
	labelStream _ WriteStream on: (String new: 200).
	self withAllSuperclasses reverseDo: [ :class | | vars |
		vars _ class classVarNames asArray sort.
		vars do: [ :var |
			labelStream nextPutAll: var; cr.
			allVars add: var.
			owningClasses add: class].
		vars isEmpty ifFalse: [ lines add: allVars size ]].
	labelStream contents isEmpty ifTrue: [^1 beep]. "handle nil superclass better"
	labelStream skip: -1 "cut last CR".
	index _ (PopUpMenu labels: labelStream contents lines: lines) startUp.
	index = 0 ifTrue: [^ self].
	Smalltalk browseAllCallsOn:
		((owningClasses at: index) classPool associationAt: (allVars at: index))! !

!ClassDescription methodsFor: 'instance variables' stamp: 'jmv 8/23/2010 09:35'!
chooseClassVarName 
	"Present the user with a list of class variable names and answer the one selected, or nil if none"

	| lines labelStream  allVars index |
	lines _ OrderedCollection new.
	allVars _ OrderedCollection new.
	labelStream _ WriteStream on: (String new: 200).
	self withAllSuperclasses reverseDo: [ :class | | vars |
		vars _ class classVarNames asArray sort.
		vars do: [ :var |
			labelStream nextPutAll: var; cr.
			allVars add: var].
		vars isEmpty ifFalse: [lines add: allVars size]].
	labelStream contents isEmpty ifTrue: [^Beeper beep]. "handle nil superclass better"
	labelStream skip: -1 "cut last CR".
	index _ (PopUpMenu labels: labelStream contents lines: lines) startUp.
	index = 0 ifTrue: [^ nil].
	^ allVars at: index! !

!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'jmv 8/23/2010 10:06'!
allMethodCategoriesIntegratedThrough: mostGenericClass
	"Answer a list of all the method categories of the receiver and all its superclasses, up through mostGenericClass"

	| aColl |
	aColl _ OrderedCollection new.
	self withAllSuperclasses do: [ :aClass |
		(aClass includesBehavior: mostGenericClass)
			ifTrue: [ aColl addAll: aClass organization categories ]].
	aColl remove: 'no messages' asSymbol ifAbsent: nil.

	^ aColl asSet asArray sort: [ :a :b | a asLowercase < b asLowercase ]

"ColorTileMorph allMethodCategoriesIntegratedThrough: TileMorph"! !

!ClassDescription methodsFor: 'organization' stamp: 'jmv 8/23/2010 09:36'!
organization
	"Answer the instance of ClassOrganizer that represents the organization 
	of the messages of the receiver."

	organization ifNil:
		[self organization: (ClassOrganizer defaultList: self methodDict keys asArray sort)].
	(organization isMemberOf: Array) ifTrue:
		[self recoverFromMDFaultWithTrace].
	
	"Making sure that subject is set correctly. It should not be necessary."
	organization ifNotNil: [organization setSubject: self].
	^ organization! !

!ClassDescription methodsFor: 'accessing class hierarchy' stamp: 'jmv 8/23/2010 10:07'!
printSubclassesOn: aStream level: level
	"As part of the algorithm for printing a description of the receiver, print the
	subclass on the file stream, aStream, indenting level times."
	| subclassNames |
	aStream crtab: level.
	aStream nextPutAll: self name.
	aStream
		 space;
		 print: self instVarNames.
	self == Class ifTrue: [
		aStream
			 crtab: level + 1;
			 nextPutAll: '[ ... all the Metaclasses ... ]'.
		^ self ].
	subclassNames _ self subclasses asArray sort: [ :c1 :c2 |
		c1 name <= c2 name ].
	"Print subclasses in alphabetical order"
	subclassNames do: [ :subclass |
		subclass
			printSubclassesOn: aStream
			level: level + 1 ].! !


!Class methodsFor: 'fileIn/Out' stamp: 'jmv 8/23/2010 09:35'!
fileOutPool: aPool onFileStream: aFileStream 

	| aPoolName |
	(aPool  isKindOf: SharedPool class) ifTrue:[^self notify: 'we do not fileout SharedPool type shared pools for now'].
	aPoolName _ Smalltalk keyAtIdentityValue: aPool.
	Transcript cr; show: aPoolName.
	aFileStream nextPutAll: 'Transcript show: ''' , aPoolName , '''; cr!!'; cr.
	aFileStream nextPutAll: 'Smalltalk at: #' , aPoolName , ' put: Dictionary new!!'; cr.
	aPool keys asArray sort do: [ :aKey | | aValue |
		aValue _ aPool at: aKey.
		aFileStream nextPutAll: aPoolName , ' at: #''' , aKey asString , '''', ' put:  '.
		(aValue isKindOf: Number)
			ifTrue: [aValue printOn: aFileStream]
			ifFalse: [aFileStream nextPutAll: '('.
					aValue printOn: aFileStream.
					aFileStream nextPutAll: ')'].
		aFileStream nextPutAll: '!!'; cr].
	aFileStream cr! !


!AbstractSound class methodsFor: 'sound library' stamp: 'jmv 8/23/2010 09:27'!
soundNames

	^ Sounds keys asArray sort! !


!CodeHolder methodsFor: 'categories' stamp: 'jmv 8/23/2010 10:12'!
categoryFromUserWithPrompt: aPrompt for: aClass
	"self new categoryFromUserWithPrompt: 'testing' for: SystemDictionary"

	|  labels myCategories reject lines newName menuIndex |
	labels _ OrderedCollection with: 'new...'.
	labels addAll: (myCategories _ aClass organization categories asArray sort:
		[ :a :b | a asLowercase < b asLowercase ]).
	reject _ myCategories asSet.
	reject
		add: ClassOrganizer nullCategory;
		add: ClassOrganizer default.
	lines _ OrderedCollection with: 1 with: (myCategories size + 1).

	aClass allSuperclasses do:
		[:cls | | cats |
			cats _ cls organization categories reject:
				 [:cat | reject includes: cat].
			cats isEmpty ifFalse:
				[lines add: labels size.
				labels addAll: (cats asArray sort:
					[:a :b | a asLowercase < b asLowercase]).
				reject addAll: cats]].

	newName _ (labels size = 1 or:
		[menuIndex _ (PopUpMenu labelArray: labels lines: lines)
		startUpWithCaption: aPrompt.
		menuIndex = 0 ifTrue: [^ nil].
		menuIndex = 1])
			ifTrue:
				[FillInTheBlank request: 'Please type new category name'
					initialAnswer: 'category name']
			ifFalse: 
				[labels at: menuIndex].
	^ newName ifNotNil: [newName asSymbol]! !

!CodeHolder methodsFor: 'message list menu' stamp: 'jmv 8/23/2010 09:36'!
browseAllMessages
	"Create and schedule a message set browser on all implementors of all the messages sent by the current method."

	| aClass aName method filteredList |
	(aName _ self selectedMessageName) ifNotNil: [
		method _ (aClass _ self selectedClassOrMetaClass) compiledMethodAt: aName.
		filteredList _ method messages reject: 
			[:each | #(new initialize = ) includes: each].
		Smalltalk browseAllImplementorsOfList: filteredList asArray sort
			 title: 'All messages sent in ', aClass name, '.', aName]! !

!CodeHolder methodsFor: 'message list menu' stamp: 'jmv 8/23/2010 09:36'!
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 _ Smalltalk allUnSentMessagesIn: unsent.
	messageList _ OrderedCollection new.
	classes do: [:c | (c selectors select: [:s | unsent includes: s]) asArray sort
					do: [:sel | messageList add: c name , ' ' , sel]].
	Smalltalk browseMessageList: messageList name: 'Unsent Methods in ', cls name! !


!Browser methodsFor: 'message category functions' stamp: 'jmv 8/23/2010 09:58'!
addCategory
	"Present a choice of categories or prompt for a new category name and add it before the current selection, or at the end if no current selection"
	| labels reject lines menuIndex oldIndex newName |
	self okToChange ifFalse: [^ self].
	classListIndex = 0 ifTrue: [^ self].
	labels _ OrderedCollection with: 'new...'.
	reject _ Set new.
	reject
		addAll: self selectedClassOrMetaClass organization categories;
		add: ClassOrganizer nullCategory;
		add: ClassOrganizer default.
	lines _ OrderedCollection new.
	self selectedClassOrMetaClass allSuperclasses do: [:cls | | cats |
		cls = Object ifFalse: [
			cats _ cls organization categories reject:
				 [:cat | reject includes: cat].
			cats isEmpty ifFalse: [
				lines add: labels size.
				labels addAll: cats asArray sort.
				reject addAll: cats]]].
	newName _ (labels size = 1 or: [
		menuIndex _ (PopUpMenu labelArray: labels lines: lines)
		startUpWithCaption: 'Add Category'.
		menuIndex = 0 ifTrue: [^ self].
		menuIndex = 1])
			ifTrue: [
				self request: 'Please type new category name'
					initialAnswer: 'category name']
			ifFalse: [
				labels at: menuIndex].
	oldIndex _ messageCategoryListIndex.
	newName isEmpty
		ifTrue: [^ self]
		ifFalse: [newName _ newName asSymbol].
	self classOrMetaClassOrganizer
		addCategory: newName
		before: (messageCategoryListIndex = 0
				ifTrue: [nil]
				ifFalse: [self selectedMessageCategoryName]).
	self changed: #messageCategoryList.
	self messageCategoryListIndex:
		(oldIndex = 0
			ifTrue: [self classOrMetaClassOrganizer categories size + 1]
			ifFalse: [oldIndex]).
	self changed: #messageCategoryList.
! !


!ChangeSorter methodsFor: 'changeSet menu' stamp: 'jmv 8/23/2010 10:06'!
chooseCngSet
	"Present the user with an alphabetical list of change set names, and let her choose one"
	| changeSetsSortedAlphabetically chosen |
	self okToChange ifFalse: [ ^ self ].
	changeSetsSortedAlphabetically _ self changeSetList asArray sort: [ :a :b |
		a asLowercase withoutLeadingDigits < b asLowercase withoutLeadingDigits ].
	chosen _ (SelectionMenu selections: changeSetsSortedAlphabetically) startUp.
	chosen ifNil: [ ^ self ].
	self showChangeSet: (ChangeSorter changeSetNamed: chosen).! !

!ChangeSorter methodsFor: 'message list' stamp: 'jmv 8/23/2010 09:35'!
messageList 

	| probe newSelectors |
	currentClassName ifNil: [^ #()].
	probe _ (currentClassName endsWith: ' class')
		ifTrue: [currentClassName]
		ifFalse: [currentClassName asSymbol].
	newSelectors _ myChangeSet selectorsInClass: probe.
	(newSelectors includes: currentSelector) ifFalse: [currentSelector _ nil].
	^ newSelectors asArray sort
! !


!Collection methodsFor: 'math functions' stamp: 'jmv 8/23/2010 09:38'!
median
	"See comment in SortedCollection"
	| sorted |
	sorted _ self asArray sort.
	^sorted at: sorted size + 1 // 2! !


!Dictionary methodsFor: 'user interface' stamp: 'jmv 8/23/2010 10:08'!
explorerContentsWithIndexCollect: twoArgBlock

	| sortedKeys |
	sortedKeys _ self keys asArray sort: [:x :y |
		((x isString and: [y isString])
			or: [x isNumber and: [y isNumber]])
			ifTrue: [x < y]
			ifFalse: [x class == y class
				ifTrue: [x printString < y printString]
				ifFalse: [x class name < y class name]]].
	^ sortedKeys collect: [:k | twoArgBlock value: (self at: k) value: k].
! !


!DifferenceFinder methodsFor: 'computing' stamp: 'jmv 8/23/2010 10:18'!
longestSequences
	| maxs points |
	maxs := self maxLengthPoints.
	points := self unfold: maxs.
	points
		sort: [:p :q | p x < q x or: [p x = q x and: [p y <= q y]]];
		do: [:p | self lcsAt: p x at: p y].
	^(Array streamContents: [:strm | 
		maxs do: [:p | | lcs |
			lcs := self lcsAt: p x at: p y.
			lcs do: [ :s | strm nextPut: s]]]) asSet! !


!FileContentsBrowser methodsFor: 'class list' stamp: 'jmv 8/23/2010 09:39'!
classList
	"Answer an array of the class names of the selected category. Answer an 
	empty array if no selection exists."

	^(systemCategoryListIndex = 0 or: [ self selectedPackage isNil ])
		ifTrue: [ #() ]
		ifFalse: [ self selectedPackage classes keys asArray sort ]! !


!FileDirectory methodsFor: 'file name utilities' stamp: 'jmv 8/23/2010 10:08'!
lastNameFor: baseFileName extension: extension
	"Assumes a file name includes a version number encoded as '.' followed by digits 
	preceding the file extension.  Increment the version number and answer the new file name.
	If a version number is not found, set the version to 1 and answer a new file name"

	| files splits |

	files _ self fileNamesMatching: (baseFileName,'*', self class dot, extension).
	splits _ files 
			collect: [:file | self splitNameVersionExtensionFor: file]
			thenSelect: [:split | (split at: 1) = baseFileName].
	splits _ splits asArray sort: [:a :b | (a at: 2) < (b at: 2)].
	^splits isEmpty 
			ifTrue: [nil]
			ifFalse: [(baseFileName, '.', (splits last at: 2) asString, self class dot, extension) asFileName]! !

!FileDirectory methodsFor: 'file name utilities' stamp: 'jmv 8/23/2010 10:08'!
nextNameFor: baseFileName extension: extension
	"Assumes a file name includes a version number encoded as '.' followed by digits 
	preceding the file extension.  Increment the version number and answer the new file name.
	If a version number is not found, set the version to 1 and answer a new file name"

	| files splits version |

	files _ self fileNamesMatching: (baseFileName,'*', self class dot, extension).
	splits _ files 
			collect: [:file | self splitNameVersionExtensionFor: file]
			thenSelect: [:split | (split at: 1) = baseFileName].
	splits _ splits asArray sort: [:a :b | (a at: 2) < (b at: 2)].
	splits isEmpty 
			ifTrue: [version _ 1]
			ifFalse: [version _ (splits last at: 2) + 1].
	^ (baseFileName, '.', version asString, self class dot, extension) asFileName! !


!FileDirectoryWrapper methodsFor: 'as yet unclassified' stamp: 'jmv 8/23/2010 10:18'!
contents

	^((model directoryNamesFor: item) asArray sort: [ :a :b | a caseInsensitiveLessOrEqual: b]) collect: [ :n | 
		FileDirectoryWrapper with: (item directoryNamed: n) name: n model: self ]! !


!FileList2 methodsFor: 'volume list and pattern' stamp: 'jmv 8/23/2010 10:09'!
listForPatterns: anArray
	"Make the list be those file names which match the patterns."

	| sizePad newList namePad sizeWithCommasPad font |
	directory ifNil: [^#()].
	(fileSelectionBlock isKindOf: MessageSend) ifTrue: [
		fileSelectionBlock arguments: {directory entries}.
		newList _ fileSelectionBlock value.
		fileSelectionBlock arguments: #().
	] ifFalse: [
		newList _ Set new.
		anArray do: [ :pat |
			newList addAll: (directory entries select: [:entry | fileSelectionBlock value: entry value: pat]) ].
	].
	newList _ newList asArray sort: self sortBlock.
	font _ Preferences standardListFont.
	namePad _ newList inject: 0 into: [ :mx :entry | mx max: (font widthOfString: entry first)].
	sizePad _ (newList inject: 0 into: [ :mx :entry | mx max: (entry at: 5)]) printString size.
	sizeWithCommasPad _ (newList inject: 0 into: [ :mx :entry | mx max: (entry at: 5)]) asStringWithCommas size.
	newList _ newList collect: [ :e | self fileNameFormattedFrom: e namePad: namePad sizePad: sizePad sizeWithCommasPad: sizeWithCommasPad ].
	^ newList! !


!MessageNode methodsFor: 'code generation (closures)' stamp: 'jmv 8/23/2010 10:09'!
analyseTempsWithin: scopeBlock "<BlockNode>" rootNode: rootNode "<MethodNode>" assignmentPools: assignmentPools "<Dictionary>"
	"Assignments within optimized loops are tricky.  Because a loop repeats a
	 write to a temporary in an optimized loop effectively occurs after the loop.
	 To handle this collect the set of temps assigned to in optimized loops and
	 add extra writes after traversing the optimized loop constituents."
	| writtenToTemps |
	self isOptimizedLoop ifTrue:
		[{ receiver }, arguments do:
			[:node|
			(node notNil and: [node isBlockNode and: [node optimized]]) ifTrue:
				[assignmentPools at: node put: Set new]]].
	"receiver is nil in cascades"
	receiver ifNotNil: [
		receiver analyseTempsWithin: scopeBlock rootNode: rootNode assignmentPools: assignmentPools].
	arguments do:
		[:node|
		node == nil ifFalse: "last argument of optimized to:do: can be nil"
			[node analyseTempsWithin: scopeBlock rootNode: rootNode assignmentPools: assignmentPools]].
	"Add assignments representing subsequent iterations
	 and redo the closure analysis for the written-to temps."
	self isOptimizedLoop ifTrue:
		[writtenToTemps := Set new.
		 { receiver }, arguments do:
			[:node|
			(node notNil and: [node isBlockNode and: [node optimized]]) ifTrue:
				[(assignmentPools removeKey: node) do:
					[:temp|
					temp isBlockArg ifFalse: "ignore added assignments to to:do: loop args"
						[writtenToTemps add: temp.
						 temp addWriteWithin: node at: rootNode locationCounter]]]].
		 writtenToTemps isEmpty ifFalse:
			[(writtenToTemps asArray sort: ParseNode tempSortBlock) do:
				[:each| each analyseClosure: rootNode].
			 (writtenToTemps collect: [:each| each definingScope]) do:
				[:blockNode|
				blockNode ifHasRemoteTempNodeEnsureInitializationStatementExists: rootNode]]]! !


!MessageSet methodsFor: 'message list' stamp: 'jmv 8/23/2010 22:17'!
sortByDate
	"Sort the message-list by date of time-stamp"

	| assocs aCompiledMethod aDate inOrder |
	assocs _ messageList collect:
		[:aRef |
			aDate _ aRef methodSymbol == #Comment
				ifTrue:
					[aRef actualClass organization dateCommentLastSubmitted]
				ifFalse:
					[aCompiledMethod _ aRef actualClass compiledMethodAt: aRef methodSymbol ifAbsent: nil.
					aCompiledMethod ifNotNil: [aCompiledMethod dateMethodLastSubmitted]].
			aRef -> (aDate ifNil: [Date fromString: '01/01/1996'])].  "The dawn of Squeak history"
	inOrder _ assocs asArray sort: [ :a :b | a value < b value].

	messageList _ inOrder collect: [:assoc | assoc key].
	self changed: #messageList! !


!MessageTally methodsFor: 'printing' stamp: 'jmv 8/23/2010 09:42'!
leavesPrintExactOn: aStream
	| dict |
	dict _ IdentityDictionary new: 100.
	self leavesInto: dict fromSender: nil.
	dict asArray sort
		do: [ :node |
			node printOn: aStream total: tally totalTime: nil tallyExact: true.
			node printSenderCountsOn: aStream ]! !

!MessageTally methodsFor: 'printing' stamp: 'jmv 8/23/2010 09:44'!
leavesPrintOn: aStream threshold: threshold
	| dict |
	dict _ IdentityDictionary new: 100.
	self leavesInto: dict fromSender: nil.
	(dict asArray select: [ :node | node tally > threshold]) sort do: [ :node |
			node printOn: aStream total: tally totalTime: time tallyExact: false ]! !

!MessageTally methodsFor: 'printing' stamp: 'jmv 8/23/2010 09:44'!
printSenderCountsOn: aStream
	| mergedSenders |
	mergedSenders _ IdentityDictionary new.
	senders do: [ :node | | mergedNode |
		mergedNode _ mergedSenders at: node method ifAbsent: nil .
		mergedNode
			ifNil: [ mergedSenders at: node method put: node ]
			ifNotNil: [ mergedNode bump: node tally ]].
	mergedSenders asArray sort do: [ :node | 
		10 to: node tally printString size by: -1 do: [ :i | aStream space ].
		node printOn: aStream total: tally totalTime: nil tallyExact: true]! !

!MessageTally methodsFor: 'printing' stamp: 'jmv 8/23/2010 09:46'!
treePrintOn: aStream tabs: tabs thisTab: myTab total: total totalTime: totalTime tallyExact: isExact orThreshold: threshold 
	| sons sonTab |
	tabs do: [:tab | aStream nextPutAll: tab].
	tabs size > 0 
		ifTrue: [
			self 
				printOn: aStream
				total: total
				totalTime: totalTime
				tallyExact: isExact].
	sons _ isExact ifTrue: [ receivers ] ifFalse: [ self sonsOver: threshold ].
	sons isEmpty 
		ifFalse: [
			tabs addLast: myTab.
			sons _ sons asArray sort.
			(1 to: sons size) do: [ :i | 
					sonTab := i < sons size ifTrue: ['  |'] ifFalse: ['  '].
					(sons at: i) 
						treePrintOn: aStream
						tabs: (tabs size < self maxTabs 
								ifTrue: [ tabs ]
								ifFalse: [ (tabs select: [:x | x = '[']) copyWith: '[' ])
						thisTab: sonTab
						total: total
						totalTime: totalTime
						tallyExact: isExact
						orThreshold: threshold ].
			tabs removeLast]! !


!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 8/23/2010 10:13'!
findWindow: evt 
	"Present a menu names of windows and naked morphs, and activate the one that gets chosen.  Collapsed windows appear below line, expand if chosen; naked morphs appear below second line; if any of them has been given an explicit name, that is what's shown, else the class-name of the morph shows; if a naked morph is chosen, bring it to front and have it don a halo."

	| menu expanded collapsed nakedMorphs |
	menu := MenuMorph new.
	expanded := SystemWindow windowsIn: self
				satisfying: [:w | w isCollapsed not].
	collapsed := SystemWindow windowsIn: self
				satisfying: [:w | w isCollapsed].
	nakedMorphs := self submorphsSatisfying: [:m | (m is: #SystemWindow) not].
	expanded isEmpty & (collapsed isEmpty & nakedMorphs isEmpty) 
		ifTrue: [^Beeper beep].
	(expanded 
		asArray sort: [:w1 :w2 | w1 label caseInsensitiveLessOrEqual: w2 label]) 
			do: 
				[:w | 
				menu 
					add: w label
					target: w
					action: #activateAndForceLabelToShow.
				w model canDiscardEdits ifFalse: [menu lastItem color: Color red]].
	expanded isEmpty | (collapsed isEmpty & nakedMorphs isEmpty) 
		ifFalse: [menu addLine].
	(collapsed 
		asArray sort: [:w1 :w2 | w1 label caseInsensitiveLessOrEqual: w2 label]) 
			do: 
				[:w | 
				menu 
					add: w label
					target: w
					action: #collapseOrExpand.
				w model canDiscardEdits ifFalse: [menu lastItem color: Color red]].
	nakedMorphs isEmpty ifFalse: [menu addLine].
	(nakedMorphs asArray sort: 
			[:w1 :w2 | 
			w1 nameForFindWindowFeature 
				caseInsensitiveLessOrEqual: w2 nameForFindWindowFeature]) 
		do: 
			[:w | 
			menu 
				add: w nameForFindWindowFeature
				target: w
				action: #comeToFrontAndAddHalo].
	menu addTitle: 'find window' translated.
	menu popUpInWorld: self! !


!ProcessBrowser methodsFor: 'process list' stamp: 'jmv 8/23/2010 10:20'!
updateProcessList
	| oldSelectedProcess newIndex now |
	now _ Time millisecondClockValue.
	now - lastUpdate < 500
		ifTrue: [^ self].
	"Don't update too fast"
	lastUpdate _ now.
	oldSelectedProcess _ selectedProcess.
	processList _ selectedProcess _ selectedSelector _ nil.
	Smalltalk garbageCollectMost.
	"lose defunct processes"

	processList _ Process allSubInstances reject: [:each | each isTerminated ].
	processList _ processList sort: [ :a :b | a priority >= b priority ].
	processList _ WeakArray withAll: processList.
	newIndex _ processList
				indexOf: oldSelectedProcess
				ifAbsent: [ 0 ].
	self changed: #processNameList.
	self processListIndex: newIndex! !


!ProtocolBrowser methodsFor: 'private' stamp: 'jmv 8/23/2010 09:46'!
on: aClass
	"Initialize with the entire protocol for the class, aClass."
	self
		initListFrom: aClass allSelectors asArray sort
		highlighting: aClass.! !

!ProtocolBrowser methodsFor: 'private' stamp: 'jmv 8/23/2010 09:46'!
onSubProtocolOf: aClass
	"Initialize with the entire protocol for the class, aClass,
		but excluding those inherited from Object."
	| selectors |
	selectors _ Set new.
	aClass withAllSuperclasses do: [ :each |
		(each == Object or: [ each == ProtoObject ]) ifFalse: [ selectors addAll: each selectors ]].
	self
		initListFrom: selectors asArray sort
		highlighting: aClass.! !


!SHTextStylerST80 methodsFor: 'private' stamp: 'jmv 8/23/2010 10:10'!
replaceStringForRangesWithType: aSymbol with: aString in: aText 
	"Answer aText if no replacements, or a copy of aText with 
	each range with a type of aSymbol replaced by aString"
	| answer toReplace adjustSourceMap increaseInLength |

	"jmvNote, 10-March-2010
	#sourceMap used to be a collection. Now it is a kind of DebuggerMethodMap.
	While we could adjust the proper ivars in the sourceMap as it was done when it was simply a collection,
	a much simpler and acceptable approach is to simply disable string replacement when in a debugger.
	This actually makes the sourceMap ivar almost useless and the processedSourceMap ivar completely useless.
	I leave them, and avoid modifying their references just in case we might want to enable string replacing in debugger again."
	sourceMap ifNotNil: [^aText].
	
	toReplace _ (self rangesIn: aText setWorkspace: false) 
		select: [:each | each type = aSymbol].
	toReplace isEmpty ifTrue: [^aText].
	answer _ aText copy.
	increaseInLength _ 0.
	adjustSourceMap _ sourceMap notNil and:[sourceMap ~~ processedSourceMap].

	(toReplace asArray sort: [:a :b | a start <= b start]) 
		do: [:each | | end start thisIncrease | 
			start _ each start + increaseInLength.
			end _ each end + increaseInLength.
			answer 	replaceFrom: start to: end with: aString.
			thisIncrease _ aString size - each length.
			increaseInLength _ increaseInLength + thisIncrease.
			adjustSourceMap ifTrue:[
				sourceMap do:[:assoc | | first newFirst last newLast |
					first _ newFirst _ assoc value first.
					last _ newLast _ assoc value last.
					first > start ifTrue:[newFirst _ first + thisIncrease].
					last > start ifTrue:[newLast _ last + thisIncrease].
					(first ~= newFirst or:[last ~= newLast])
						ifTrue:[assoc value: (newFirst to: newLast)]]]].
	adjustSourceMap ifTrue:[processedSourceMap _ sourceMap]. 
	^answer! !


!SampledInstrument methodsFor: 'other' stamp: 'jmv 8/23/2010 10:10'!
allNotes
	"Answer a collection containing of all the unique sampled sounds used by this instrument."

	| r |
	r _ IdentitySet new.
	r addAll: sustainedLoud.
	sustainedSoft ~~ sustainedLoud ifTrue: [r addAll: sustainedSoft].
	staccatoLoud ~~ sustainedLoud ifTrue: [r addAll: staccatoLoud].
	staccatoSoft ~~ staccatoLoud ifTrue: [r addAll: staccatoSoft].
	^ r asArray sort: [:n1 :n2 | n1 pitch < n2 pitch]! !


!SequenceDifference methodsFor: 'accessing' stamp: 'jmv 8/23/2010 10:31'!
x: aCollection y: anotherCollection lcs: pairCollection
	x := aCollection.
	y := anotherCollection.
	lcs := pairCollection sort: [ :a :b | a first < b first ]! !


!SimpleHierarchicalListMorph methodsFor: 'private' stamp: 'jmv 8/23/2010 10:11'!
addMorphsTo: morphList from: aCollection allowSorting: sortBoolean withExpandedItems: expandedItems atLevel: newIndent

	| priorMorph newCollection firstAddition |
	priorMorph _ nil.
	newCollection _ (sortBoolean and: [sortingSelector notNil]) ifTrue: [
		aCollection asOrderedCollection sort: [ :a :b | 
			(a perform: sortingSelector) <= (b perform: sortingSelector)]
	] ifFalse: [
		aCollection
	].
	firstAddition _ nil.
	newCollection do: [:item | 
		priorMorph _ self indentingItemClass basicNew 
			initWithContents: item 
			prior: priorMorph 
			forList: self
			indentLevel: newIndent.
		firstAddition ifNil: [firstAddition _ priorMorph].
		morphList add: priorMorph.
		((item hasEquivalentIn: expandedItems) or: [priorMorph isExpanded]) ifTrue: [
			priorMorph isExpanded: true.
			priorMorph 
				addChildrenForList: self 
				addingTo: morphList
				withExpandedItems: expandedItems.
		].
	].
	^firstAddition
	
! !

!SimpleHierarchicalListMorph methodsFor: 'private' stamp: 'jmv 8/23/2010 10:11'!
addSubmorphsAfter: parentMorph fromCollection: aCollection allowSorting: sortBoolean

	| priorMorph morphList newCollection |
	priorMorph _ nil.
	newCollection _ (sortBoolean and: [sortingSelector notNil]) ifTrue: [
		aCollection asOrderedCollection sort: [ :a :b | 
			(a perform: sortingSelector) <= (b perform: sortingSelector)]
	] ifFalse: [
		aCollection
	].
	morphList _ OrderedCollection new.
	newCollection do: [:item | 
		priorMorph _ self indentingItemClass basicNew 
			initWithContents: item 
			prior: priorMorph 
			forList: self
			indentLevel: parentMorph indentLevel + 1.
		morphList add: priorMorph.
	].
	scroller addAllMorphs: morphList after: parentMorph.
	^morphList
	
! !


!SpaceTally methodsFor: 'fileOut' stamp: 'jmv 8/23/2010 09:49'!
compareTallyIn: beforeFileName to: afterFileName
	"SpaceTally new compareTallyIn: 'tally' to: 'tally2'"

	| answer s beforeDict a afterDict allKeys before after diff |
	beforeDict _ Dictionary new.
	s _ FileDirectory default fileNamed: beforeFileName.
	 [s atEnd ] whileFalse: [
		a _ Array readFrom: s nextLine.
		beforeDict at: a first put: a allButFirst.
	].
	s close.
	afterDict _ Dictionary new.
	s _ FileDirectory default fileNamed: afterFileName.
	[ s atEnd ] whileFalse: [
		a _ Array readFrom: s nextLine.
		afterDict at: a first put: a allButFirst.
	].
	s close.
	answer _ WriteStream on: String new.
	allKeys _ (Set new addAll: beforeDict keys; addAll: afterDict keys; yourself) asArray sort.
	allKeys do: [ :each |
		before _ beforeDict at: each ifAbsent: [#(0 0 0)].
		after _ afterDict at: each ifAbsent: [#(0 0 0)].
		diff _ before with: after collect: [ :vBefore :vAfter | vAfter - vBefore].
		diff = #(0 0 0) ifFalse: [
			answer nextPutAll: each, '  ', diff printString; cr.
		].
	].
	StringHolder new contents: answer contents; openLabel: 'space diffs'! !

!SpaceTally methodsFor: 'fileOut' stamp: 'jmv 8/23/2010 10:12'!
printSpaceAnalysis: threshold on: aStream
	"SpaceTally new printSpaceAnalysis: 1 on:(FileStream forceNewFileNamed: 'STspace.text')"

	"sd-This method should be rewrote to be more coherent within the rest of the class 
	ie using preAllocate and spaceForInstanceOf:"

	"If threshold > 0, then only those classes with more than that number
	of instances will be shown, and they will be sorted by total instance space.
	If threshold = 0, then all classes will appear, sorted by name."

	| codeSpace instCount instSpace totalCodeSpace totalInstCount totalInstSpace eltSize n totalPercent percent |
	Smalltalk garbageCollect.
	totalCodeSpace _ totalInstCount _ totalInstSpace _ n _ 0.
	results _ OrderedCollection new: Smalltalk classNames size.
'Taking statistics...'
	displayProgressAt: Sensor cursorPoint
	from: 0 to: Smalltalk classNames size
	during: [:bar |
	Smalltalk allClassesDo:
		[:cl | codeSpace _ cl spaceUsed.
		bar value: (n _ n+1).
		Smalltalk garbageCollectMost.
		instCount _ cl instanceCount.
		instSpace _ (cl indexIfCompact > 0 ifTrue: [4] ifFalse: [8])*instCount. "Object headers"
		cl isVariable
			ifTrue: [eltSize _ cl isBytes ifTrue: [1] ifFalse: [4].
					cl allInstancesDo: [:x | instSpace _ instSpace + (x basicSize*eltSize)]]
			ifFalse: [instSpace _ instSpace + (cl instSize*instCount*4)].
		results add: (SpaceTallyItem analyzedClassName: cl name codeSize: codeSpace instanceCount:  instCount spaceForInstances: instSpace).
		totalCodeSpace _ totalCodeSpace + codeSpace.
		totalInstCount _ totalInstCount + instCount.
		totalInstSpace _ totalInstSpace + instSpace]].
	totalPercent _ 0.0.

	aStream timeStamp.
	aStream
		nextPutAll: ('Class' padded: #right to: 30 with: $ );
		nextPutAll: ('code space' padded: #left to: 12 with: $ );
		nextPutAll: ('# instances' padded: #left to: 12 with: $ );
		nextPutAll: ('inst space' padded: #left to: 12 with: $ );
		nextPutAll: ('percent' padded: #left to: 8 with: $ ); cr.

	threshold > 0 ifTrue: [
		"If inst count threshold > 0, then sort by space"
		results _ (results select: [:s | s instanceCount >= threshold or: [s spaceForInstances > (totalInstSpace // 500)]])
			asArray sort: [:s :s2 | s spaceForInstances > s2 spaceForInstances]].

	results do: [:s |
		aStream
			nextPutAll: (s analyzedClassName padded: #right to: 30 with: $ );
			nextPutAll: (s codeSize printString padded: #left to: 12 with: $ );
			nextPutAll: (s instanceCount printString padded: #left to: 12 with: $ );
			nextPutAll: (s spaceForInstances printString padded: #left to: 14 with: $ ).
		percent _ s spaceForInstances*100.0/totalInstSpace roundTo: 0.1.
		totalPercent _ totalPercent + percent.
		percent >= 0.1 ifTrue: [
			aStream nextPutAll: (percent printString padded: #left to: 8 with: $ )].
		aStream cr].

	aStream
		cr; nextPutAll: ('Total' padded: #right to: 30 with: $ );
		nextPutAll: (totalCodeSpace printString padded: #left to: 12 with: $ );
		nextPutAll: (totalInstCount printString padded: #left to: 12 with: $ );
		nextPutAll: (totalInstSpace printString padded: #left to: 14 with: $ );
		nextPutAll: ((totalPercent roundTo: 0.1) printString padded: #left to: 8 with: $ ).! !


!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 8/23/2010 09:52'!
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.
			Smalltalk 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: nil.
					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 ]]]].
	Smalltalk
		browseMessageList: badOnes asArray sort
		name: 'Decompiler Discrepancies'.! !

!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 8/23/2010 09:52'!
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 classic monochrome."
	| 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.
			Smalltalk 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.
					methodNode _ cls compilerClass new
						compile: newCodeString
						in: cls
						notifying: nil
						ifFail: nil.
					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 ]]]].
	Smalltalk
		browseMessageList: badOnes asArray sort
		name: 'Formatter Discrepancies'.! !

!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 8/23/2010 09:52'!
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 classic monochrome"
	| 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.
			Smalltalk 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.
					oldTokens _ oldCodeString findTokens: Character separators.
					newTokens _ newCodeString findTokens: Character separators.
					oldTokens = newTokens ifFalse: [
						Transcript
							 cr;
							 show: '***' , cls name , ' ' , selector.
						badOnes add: cls name , ' ' , selector ]]]].
	Smalltalk
		browseMessageList: badOnes asArray sort
		name: 'Formatter Discrepancies'.! !

!SystemDictionary methodsFor: 'retrieving' stamp: 'jmv 8/23/2010 09:50'!
allImplementorsOf: aSelector  localTo: aClass
	"Answer a sorted Collection 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 asArray sort! !

!SystemDictionary methodsFor: 'retrieving' stamp: 'jmv 8/23/2010 09:50'!
allMethodsWithSourceString: aString matchCase: caseSensitive
	"Answer a sorted Collection 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 asArray sort.! !

!SystemDictionary methodsFor: 'retrieving' stamp: 'jmv 8/23/2010 09:50'!
allMethodsWithString: aString
	"Answer a sorted Collection of all the methods that contain, in a string literal, aString as a substring.  2/1/96 sw.  The search is case-sensitive, and does not dive into complex literals, confining itself to string constants.
	5/2/96 sw: fixed so that duplicate occurrences of aString in the same method don't result in duplicated entries in the browser"
	| aStringSize list lits |
	aStringSize _ aString size.
	list _ Set new.
	Cursor wait showWhile: [
		self allBehaviorsDo: [ :class |
			class selectorsDo: [ :sel |
				sel ~~ #DoIt ifTrue: [
					lits _ (class compiledMethodAt: sel) literals.
					lits do: [ :aLiteral |
						((aLiteral isMemberOf: String) and: [ aLiteral size >= aStringSize ]) ifTrue: [
							(aLiteral
								findString: aString
								startingAt: 1) > 0 ifTrue: [ list add: class name , ' ' , sel ]]]]]]].
	^ list asArray sort.! !

!SystemDictionary methodsFor: 'browsing' stamp: 'jmv 8/23/2010 09:50'!
browseAllCallsOn: aLiteral
	"Create and schedule a message browser on each method that refers to
	aLiteral. For example, Smalltalk browseAllCallsOn: #open:label:."
	(aLiteral isKindOf: LookupKey)
		ifTrue: [
			self
				browseMessageList: (self allCallsOn: aLiteral) asArray sort
				name: 'Users of ' , aLiteral key
				autoSelect: aLiteral key ]
		ifFalse: [
			self
				browseMessageList: (self allCallsOn: aLiteral) asArray sort
				name: 'Senders of ' , aLiteral
				autoSelect: aLiteral keywords first ].! !

!SystemDictionary methodsFor: 'browsing' stamp: 'jmv 8/23/2010 09:51'!
browseAllCallsOn: aLiteral localTo: aClass
	"Create and schedule a message browser on each method in or below the given class that refers to
	aLiteral. For example, Smalltalk browseAllCallsOn: #open:label:."
	aClass ifNil: [ ^ self inform: 'no selected class' ].
	(aLiteral isKindOf: LookupKey)
		ifTrue: [
			self
				browseMessageList: (aClass allLocalCallsOn: aLiteral) asArray sort
				name: 'Users of ' , aLiteral key , ' local to ' , aClass name
				autoSelect: aLiteral key ]
		ifFalse: [
			self
				browseMessageList: (aClass allLocalCallsOn: aLiteral) asArray sort
				name: 'Senders of ' , aLiteral , ' local to ' , aClass name
				autoSelect: aLiteral keywords first ].! !

!SystemDictionary methodsFor: 'browsing' stamp: 'jmv 8/23/2010 09:51'!
browseAllCallsOnClass: aClass
	"Create and schedule a message browser on each method that refers to 
	aClass. For example, SystemNavigation new browseAllCallsOnClass: Object."
	self
		browseMessageList: aClass allCallsOn asArray sort
		name: 'Users of class ' , aClass theNonMetaClass name
		autoSelect: aClass theNonMetaClass name.! !

!SystemDictionary methodsFor: 'browsing' stamp: 'jmv 8/23/2010 22:21'!
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,  Smalltalk 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 _ Array streamContents: [ :stream |
		implementorLists do: [ :each | stream nextPutAll: each]].
	flattenedList sort.
	Cursor normal show.
	^ self browseMessageList: flattenedList name: aTitle! !

!SystemDictionary methodsFor: 'browsing' stamp: 'jmv 8/23/2010 09:51'!
browseClassCommentsWithString: aString
	"Smalltalk browseClassCommentsWithString: 'my instances' "
	"Launch a message list browser on all class comments containing aString as a substring."
	| caseSensitive suffix list |
	suffix _ (caseSensitive _ Sensor shiftPressed)
		ifTrue: [ ' (case-sensitive)' ]
		ifFalse: [ ' (use shift for case-sensitive)' ].
	list _ Set new.
	Cursor wait showWhile: [
		Smalltalk allClassesDo: [ :class |
			(class organization classComment asString
				findString: aString
				startingAt: 1
				caseSensitive: caseSensitive) > 0 ifTrue: [
				list add:
					(MethodReference new
						setStandardClass: class
						methodSymbol: #Comment) ]]].
	^ self
		browseMessageList: list asArray sort
		name: 'Class comments containing ', aString printString, suffix
		autoSelect: aString.! !

!SystemDictionary methodsFor: 'browsing' stamp: 'jmv 8/23/2010 09:52'!
showMenuOf: selectorCollection withFirstItem: firstItem ifChosenDo: choiceBlock withCaption: aCaption
	"Show a sorted menu of the given selectors, preceded by firstItem, and all abbreviated to 40 characters.  Use aCaption as the menu title, if it is not nil.  Evaluate choiceBlock if a message is chosen."
	| index menuLabels sortedList aMenu |
	sortedList _ selectorCollection asArray sort.
	menuLabels _ String streamContents: [ :strm |
		strm nextPutAll: (firstItem contractTo: 40).
		sortedList do: [ :sel |
			strm
				 cr;
				 nextPutAll: (sel contractTo: 40) ]].
	aMenu _ PopUpMenu
		labels: menuLabels
		lines: #(1 ).
	index _ aCaption
		ifNil: [ aMenu startUp ]
		ifNotNil: [ aMenu startUpWithCaption: aCaption ].
	index = 1 ifTrue: [ choiceBlock value: firstItem ].
	index > 1 ifTrue: [ choiceBlock value: (sortedList at: index - 1) ].! !


!SystemVersion methodsFor: 'accessing' stamp: 'jmv 8/23/2010 09:55'!
highestUpdate
	highestUpdate ifNil: [
		highestUpdate _ self updates
			ifEmpty: [ 0 ]
			ifNotEmpty: [ :upd | upd max ]].
	^ highestUpdate.! !


!TempVariableNode methodsFor: 'printing' stamp: 'jmv 8/23/2010 09:55'!
printDefinitionForClosureAnalysisOn: aStream 
	| refs |
	aStream
		nextPut: ${;
		nextPutAll: key.
	definingScope ifNotNil: [definingScope blockExtent ifNotNil: [:be| aStream nextPutAll: ' d@'; print: be first]].
	readingScopes ifNotNil: [
		refs := Set new.
		readingScopes do: [:elems| refs addAll: elems].
		refs asArray sort do: [:read| aStream nextPutAll: ' r@'; print: read]].
	writingScopes ifNotNil: [
		refs := Set new.
		writingScopes do: [:elems| refs addAll: elems].
		refs asArray sort do: [:write| aStream nextPutAll: ' w@'; print: write]].
	aStream nextPut: $}! !

!TempVariableNode methodsFor: 'printing' stamp: 'jmv 8/23/2010 09:56'!
printWithClosureAnalysisOn: aStream indent: level
	aStream nextPutAll: name.
	readingScopes ifNotNil: [
		(readingScopes
			inject: Set new
			into: [ :them :reads |
				them addAll: reads.
				them ]) asArray sort do: [ :location |
			aStream
				 space;
				 nextPut: $r;
				 nextPut: $@;
				 print: location ]].
	writingScopes ifNotNil: [
		(writingScopes
			inject: Set new
			into: [ :them :writes |
				them addAll: writes.
				them ]) asArray sort do: [ :location |
			aStream
				 space;
				 nextPut: $w;
				 nextPut: $@;
				 print: location ]].! !


!RemoteTempVectorNode methodsFor: 'printing' stamp: 'jmv 8/23/2010 09:49'!
printDefinitionForClosureAnalysisOn: aStream 
	| refs |
	aStream
		nextPut: ${;
		nextPutAll: key.
	definingScope ifNotNil: [ definingScope blockExtent ifNotNil: [:be| aStream nextPutAll: ' d@'; print: be first ]].
	readingScopes ifNotNil: [
		refs := Set new.
		readingScopes do: [ :elems | refs addAll: elems ].
		refs asArray sort do: [ :read | aStream nextPutAll: ' r@'; print: read ]].
	remoteTemps
		do: [ :rt | rt printDefinitionForClosureAnalysisOn: aStream ]
		separatedBy: [ aStream nextPut: $,; space ].
	aStream nextPut: $}! !


!TestRunner methodsFor: 'initialize' stamp: 'jmv 8/23/2010 09:56'!
gatherTestNames
	^ (self testCases collect: [ :each |
		each name ]) asArray sort.! !


!TheWorldMenu methodsFor: 'commands' stamp: 'jmv 8/23/2010 10:12'!
worldMenuHelp
	| aList aMenu cnts explanation |
	"self currentWorld primaryHand worldMenuHelp"

	aList _ OrderedCollection new.
	#(helpMenu changesMenu openMenu debugMenu windowsMenu appearanceMenu) 
		with:
	#('help' 'changes' 'open' 'debug' 'windows' 'appearance' ) do:
		[:sel :title | aMenu _ self perform: sel.
			aMenu items do:
				[:it | (((cnts _ it contents) = 'keep this menu up') or: [cnts isEmpty])
					ifFalse: [aList add: (cnts, ' - ', title translated)]]].
	aList _ aList asArray sort: [:a :b | a asLowercase < b asLowercase].

	explanation _ String streamContents: [:aStream | aList do:
		[:anItem | aStream nextPutAll: anItem; cr]].

	(StringHolder new contents: explanation)
		openLabel: 'Where in the world menu is...' translated! !

!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 8/23/2010 10:20'!
alphabeticalMorphMenu
	| list splitLists menu firstChar lastChar subMenu |
	list := Morph withAllSubclasses select: [:m | m includeInNewMorphMenu].
	list := list asArray sort: [:c1 :c2 | c1 name < c2 name].
	splitLists := self splitNewMorphList: list depth: 3.
	menu := MenuMorph new defaultTarget: self.
	1 to: splitLists size
		do: 
			[:i | 
			firstChar := i = 1 
				ifTrue: [$A]
				ifFalse: 
					[((splitLists at: i - 1) last name first asInteger + 1) 
								asCharacter].
			lastChar := i = splitLists size 
						ifTrue: [$Z]
						ifFalse: [(splitLists at: i) last name first].
			subMenu := MenuMorph new.
			(splitLists at: i) do: 
					[:cl | 
					subMenu 
						add: cl name
						target: self
						selector: #newMorphOfClass:event:
						argument: cl].
			menu add: firstChar asString , ' - ' , lastChar asString subMenu: subMenu].
	^menu! !

!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 8/23/2010 10:12'!
newMorph
	"The user requested 'new morph' from the world menu.  Put up a menu that allows many ways of obtaining new morphs.  If the preference #classicNewMorphMenu is true, the full form of yore is used; otherwise, a much shortened form is used."
	| menu subMenu catDict shortCat class |
	menu _ self menu: 'Add a new morph'.
	menu
		
		add: 'from paste buffer' translated
		target: myHand
		action: #pasteMorph;
		
		add: 'from alphabetical list' translated
		subMenu: self alphabeticalMorphMenu.
	menu addLine.
	Preferences classicNewMorphMenu ifTrue: [
		menu addLine.
		catDict _ Dictionary new.
		SystemOrganization categories do: [ :cat |
			((cat beginsWith: 'Morphic-') and: [ (#('Morphic-Menus' 'Morphic-Support' ) includes: cat) not ]) ifTrue: [
				shortCat _ (cat
					copyFrom: 'Morphic-' size + 1
					to: cat size) translated.
				(SystemOrganization listAtCategoryNamed: cat) do: [ :cName |
					class _ Smalltalk at: cName.
					((class inheritsFrom: Morph) and: [ class includeInNewMorphMenu ]) ifTrue: [
						(catDict includesKey: shortCat)
							ifTrue: [ (catDict at: shortCat) addLast: class ]
							ifFalse: [
								catDict
									at: shortCat
									put: (OrderedCollection with: class) ]]]]].
		catDict keys asArray sort do: [ :categ |
			subMenu _ MenuMorph new.
			((catDict at: categ) asArray sort: [ :c1 :c2 |
				c1 name < c2 name ]) do: [ :cl |
				subMenu
					add: cl name
					target: self
					selector: #newMorphOfClass:event:
					argument: cl ].
			menu
				add: categ
				subMenu: subMenu ]].
	self doPopUp: menu.! !


!Time class methodsFor: 'general inquiries' stamp: 'jmv 8/23/2010 09:57'!
condenseBunches: aCollectionOfSeconds
	"Identify the major intervals in a bunch of numbers.  Each number is a seconds since 1901 that represents a date and time.  We want the last event in a bunch.  Return array of seconds for:
	Every event in the last half hour.
	Every bunch separated by 30 min in the last 24 hours.
	Every bunch separated by two hours before that."
	"Time condenseBunches: 
	(#(20 400 401  20000 20200 20300   40000 45000  200000 201000 202000) collect: [:tt | 
		self totalSeconds - tt]) 
"
	| secArray pause now out prev bunchEnd ago |
	secArray _ aCollectionOfSeconds asArray sort.
	pause _ 1.
	now _ self totalSeconds.
	out _ OrderedCollection new.
	prev _ 0.
	bunchEnd _ nil.
	secArray reverseDo: [ :secs |
		"descending"
		ago _ now - secs.
		ago > (60 * 30) ifTrue: [ pause _ 1800 "60*30" ].
		ago > (60 * 60 * 24) ifTrue: [ pause _ 7200 "60*120" ].
		ago - prev >= pause ifTrue: [
			out add: bunchEnd.
			bunchEnd _ secs ].
		prev _ ago ].
	out add: bunchEnd.
	out removeFirst.
	^ out.! !


!Utilities class methodsFor: 'closure support' stamp: 'jmv 8/23/2010 09:57'!
compileUsingClosures	"Utilities compileUsingClosures"
	"Recompile the system and do some minimal clean-ups"
	| classes compilationErrors |
	Preferences setPreference: #allowBlockArgumentAssignment toValue: false.
	compilationErrors := Set new.
	classes := Smalltalk forgetDoIts allClasses reject: [:c| c name == #GeniePlugin].

	'Recompiling The System' displayProgressAt: Sensor cursorPoint
		from: 0 to: classes size during:[:bar |
			classes withIndexDo:[:c :i|
				bar value: i.
				{ c. c class } do:[:b|
					"Transcript cr; print: b; endEntry."
					b selectors "asArray sort" do: [ :s | 
						"Transcript cr; show: b asString, '>>', s."
						[b recompile: s from: b] on: Error do:[:ex|
							Transcript
								cr; nextPutAll: 'COMPILATION ERROR: ';
								print: b; nextPutAll: '>>'; nextPutAll: s; flush.
							compilationErrors add: (MethodReference class: b selector: s)]]]]].

	compilationErrors notEmpty ifTrue:[
		Smalltalk
			browseMessageList: compilationErrors asArray sort
			name: 'Compilation Errors']! !


!ZipWriteStream class methodsFor: 'regression test' stamp: 'jmv 8/23/2010 09:59'!
regressionTestFrom: fd using: tempName stats: stats
	| files file fullName |
	files _ fd fileNames asArray sort.
	files do: [ :fName |
		file _ nil.
		fullName _ fd fullNameFor: fName.
		fullName = tempName ifFalse: [
			file _ StandardFileStream new
				open: fullName
				forWrite: false ].
		self
			compressAndDecompress: file
			using: tempName
			stats: stats ].
	stats
		at: #numFiles
		put:
			(stats
				at: #numFiles
				ifAbsent: [ 0 ]) + files size.
	files _ nil.
	self
		printRegressionStats: stats
		from: fd.
	fd directoryNames asArray sort do: [ :dName |
		self
			regressionTestFrom: (fd directoryNamed: dName)
			using: tempName
			stats: stats ].! !

SequenceableCollection removeSelector: #sortBy:!
