'From Cuis 2.0 of 24 February 2010 [latest update: #440] on 1 March 2010 at 3:26:03 pm'!

!Categorizer methodsFor: 'accessing' stamp: 'jmv 3/1/2010 14:50'!
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 asSortedCollection do:
			[:elem |
			(oldElements remove: elem ifAbsent: [nil]) notNil ifTrue:
				[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].! !


!ClassDescription methodsFor: 'instance variables' stamp: 'jmv 3/1/2010 14:54'!
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 asSortedCollection.
		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 3/1/2010 14:59'!
replaceSilently: old to: new
	"text-replace any part of a method.  Used for class and pool variables.  Don't touch the header.  Not guaranteed to work if name appears in odd circumstances"
	| oldName newName |

	oldName _ old asString.
	newName _ new asString.
	self withAllSubclasses do: [ :cls | | oldCode newCode sels |
		sels _ cls selectors.
		sels removeAllFoundIn: #(DoIt DoItIn:).
		sels do: [ :sel | | parser header body |
			oldCode _ cls sourceCodeAt: sel.
			"Don't make changes in the method header"
			(parser _ cls parserClass new) parseSelector: oldCode.
			header _ oldCode copyFrom: 1 to: (parser endOfLastToken min: oldCode size).
			body _ header size > oldCode size
					ifTrue: ['']
					ifFalse: [oldCode copyFrom: header size+1 to: oldCode size].
			newCode _ header , (body copyReplaceTokens: oldName with: newName).
			newCode ~= oldCode ifTrue:
				[cls compile: newCode
					classified: (cls organization categoryOfElement: sel)
					notifying: nil]].
		cls isMeta ifFalse: [
			oldCode _ cls comment.
			newCode _ oldCode copyReplaceTokens: oldName with: newName.
			newCode ~= oldCode ifTrue: [
				cls comment: newCode]]]! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'jmv 3/1/2010 14:55'!
definition
	"Answer a String that defines the receiver."

	| aStream path |
	aStream _ WriteStream on: (String new: 300).
	superclass
		ifNil: [aStream nextPutAll: 'ProtoObject']
		ifNotNil: [
			path _ ''.
				Smalltalk 
					scopeFor: superclass name 
					from: nil
					envtAndPathIfFound: [:envt :remotePath | path _ remotePath].
				aStream nextPutAll: path , superclass name].
	aStream nextPutAll: self kindOfSubclass;
			store: self name.
	aStream cr; tab; nextPutAll: 'instanceVariableNames: ';
			store: self instanceVariablesString.
	aStream cr; tab; nextPutAll: 'classVariableNames: ';
			store: self classVariablesString.
	aStream cr; tab; nextPutAll: 'poolDictionaries: ';
			store: self sharedPoolsString.
	aStream cr; tab; nextPutAll: 'category: ';
			store: (SystemOrganization categoryOfElement: self name) asString.

	superclass ifNil: [ 
		aStream nextPutAll: '.'; cr.
		aStream nextPutAll: self name.
		aStream space; nextPutAll: 'superclass: nil'. ].

	^ aStream contents! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'jmv 3/1/2010 14:55'!
fileOutChangedMessages: aSet on: aFileStream moveSource: moveSource toFile: fileIndex 
	"File a description of the messages of this class that have been 
	changed (i.e., are entered into the argument, aSet) onto aFileStream.  If 
	moveSource, is true, then set the method source pointer to the new file position.
	Note when this method is called with moveSource=true, it is condensing the
	.changes file, and should only write a preamble for every method."
	| org |
	(org _ self organization) categories do: [ :cat |  | sels |
		sels _ (org listAtCategoryNamed: cat) select: [:sel | aSet includes: sel].
		sels do: [:sel |
			self printMethodChunk: sel withPreamble: true on: aFileStream moveSource: moveSource toFile: fileIndex]]! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'jmv 3/1/2010 14:57'!
putClassCommentToCondensedChangesFile: aFileStream
	"Called when condensing changes.  If the receiver has a class comment, and if that class comment does not reside in the .sources file, then write it to the given filestream, with the resulting RemoteString being reachable from the source file #2.  Note that any existing backpointer into the .sources file is lost by this process -- a situation that maybe should be fixed someday."

	| header aCommentRemoteStr aStamp |
	self isMeta ifTrue: [^ self].  "bulletproofing only"
	((aCommentRemoteStr _ self organization commentRemoteStr) isNil or:
		[aCommentRemoteStr sourceFileNumber = 1]) ifTrue: [^ self].

	aFileStream cr; nextPut: $!!.
	header _ String streamContents: [:strm | 
		strm 
			nextPutAll: self name;
			nextPutAll: ' commentStamp: '.
		(aStamp _ self organization commentStamp ifNil: ['<historical>']) storeOn: strm.
		strm nextPutAll: ' prior: 0'].
	aFileStream nextChunkPut: header.
	aFileStream cr.
	self organization classComment: (RemoteString newString: self organization classComment onFileNumber: 2 toFile: aFileStream) stamp: aStamp! !

!ClassDescription methodsFor: 'private' stamp: 'jmv 3/1/2010 14:56'!
linesOfCode  "InterpreterSimulator linesOfCode 790"
	"An approximate measure of lines of code.
	Includes comments, but excludes blank lines."

	| lines |
	lines _ 0.
	self selectorsDo: [ :sel | | code strm |
		code _ self sourceCodeAt: sel.
		strm _ ReadStream on: code.
		[strm atEnd] whileFalse: [ | line |
			line _ strm upTo: Character cr.
			line isEmpty ifFalse: [lines _ lines+1]]].
	^self isMeta
		ifTrue: [ lines]
		ifFalse: [ lines + self class linesOfCode]
"
(SystemOrganization categories select: [:c | 'Fabrik*' match: c]) detectSum:
		[:c | (SystemOrganization superclassOrder: c) detectSum: [:cl | cl linesOfCode]] 24878
"! !


!AbstractSound class methodsFor: 'examples' stamp: 'jmv 3/1/2010 14:41'!
majorScaleOn: aSound from: aPitch octaves: octaveCount
	"(AbstractSound majorScaleOn: FMSound oboe1 from: #c2 octaves: 5) play"

	| startingPitch pitches |
	startingPitch _ aPitch isNumber
		ifTrue: [aPitch]
		ifFalse: [self pitchForName: aPitch].
	pitches _ OrderedCollection new.
	0 to: octaveCount - 1 do: [ :i | | chromatic |
		chromatic _ self chromaticPitchesFrom: startingPitch * (2 raisedTo: i).
		#(1 3 5 6 8 10 12) do: [ :j | pitches addLast: (chromatic at: j)]].
	pitches addLast: startingPitch * (2 raisedTo: octaveCount).
	^ self noteSequenceOn: aSound
		from: (pitches collect: [ :pitch | Array with: pitch with: 0.5 with: 300])
! !


!BalloonMorph class methodsFor: 'private' stamp: 'jmv 3/1/2010 14:46'!
getBestLocation: vertices for: morph corner: cornerName
	"Try four rel locations of the balloon for greatest unclipped area.   12/99 sma"

	| rect maxArea verts mp bestVerts usableArea |
	rect _ vertices first rect: (vertices at: 5).
	maxArea _ -1.
	verts _ vertices.
	usableArea _ (morph world ifNil: [self currentWorld]) viewBox.
	1 to: 4 do: [ :i | | a rectCorner morphPoint mbc dir |
		dir _ #(vertical horizontal) atWrap: i.
		verts _ verts collect: [:p | p flipBy: dir centerAt: rect center].
		rectCorner _ #(bottomLeft bottomRight topRight topLeft) at: i.
		morphPoint _ #(topCenter topCenter bottomCenter bottomCenter) at: i.
		a _ ((rect
			align: (rect perform: rectCorner)
			with: (mbc _ morph boundsForBalloon perform: morphPoint))
				intersect: usableArea) area.
		(a > maxArea or: [a = rect area and: [rectCorner = cornerName]]) ifTrue: [
			maxArea _ a.
			bestVerts _ verts.
			mp _ mbc]].
	^bestVerts collect: [:p | p + (mp - bestVerts first)] "Inlined align:with:"! !


!CodeHolder methodsFor: 'categories' stamp: 'jmv 3/1/2010 15:01'!
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 asSortedCollection:
		[: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 asSortedCollection:
					[: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: 'commands' stamp: 'jmv 3/1/2010 15:02'!
copyUpOrCopyDown
	"Used to copy down code from a superclass to a subclass or vice-versa in one easy step, if you know what you're doing.  Prompt the user for which class to copy down or copy up to, then spawn a fresh browser for that class, with the existing code planted in it, and with the existing method category also established."

	| aClass aSelector allClasses implementors aMenu |
	((aClass := self selectedClassOrMetaClass) isNil 
		or: [(aSelector := self selectedMessageName) == nil]) 
			ifTrue: [^Beeper beep].
	allClasses := Utilities hierarchyOfClassesSurrounding: aClass.
	implementors := Smalltalk hierarchyOfImplementorsOf: aSelector
				forClass: aClass.
	aMenu := MenuMorph new defaultTarget: self.
	aMenu title: aClass name , '.' , aSelector 
				, '
Choose where to insert a copy of this method
(blue = current, black = available, red = other implementors'.
	allClasses do: 
			[:cl | | aColor |
			aColor := cl == aClass 
						ifTrue: [#blue]
						ifFalse: [(implementors includes: cl) ifTrue: [#red] ifFalse: [#black]].
			aColor == #red 
				ifFalse: 
					[aMenu 
						add: cl name
						selector: #spawnToClass:
						argument: cl]
				ifTrue: 
					[aMenu 
						add: cl name
						selector: #spawnToCollidingClass:
						argument: cl].
			aMenu lastItem color: (Color colorFrom: aColor)].
	aMenu popUpInWorld! !

!CodeHolder methodsFor: 'controls' stamp: 'jmv 3/1/2010 15:02'!
optionalButtonRow
	"Answer a row of control buttons"

	| row buttons widths |
	buttons _ OrderedCollection new.
	widths _ OrderedCollection new.
	Preferences menuButtonInToolPane ifTrue: [
		buttons add: self menuButton.
		widths add: 4 ].
	self optionalButtonTuples do: [ :tuple | | button aLabel |
		widths add: tuple first.
		button _ PluggableButtonMorph 
					model: self
					stateGetter: nil
					action: tuple third.
		aLabel := Preferences abbreviatedBrowserButtons 
			ifTrue: [self abbreviatedWordingFor: tuple third]
			ifFalse: [nil].
		button label: (aLabel ifNil: [tuple second asString]).
		tuple size > 3 ifTrue: [button setBalloonText: tuple fourth].
		tuple size > 4 ifTrue: [button triggerOnMouseDown: tuple fifth].
		buttons add: button ].
	row _ AlignmentMorph proportional.
	row addInRow: buttons widthProportionalTo: widths.
	^row! !


!ChangeList methodsFor: 'menu actions' stamp: 'jmv 3/1/2010 14:51'!
selectRemovalsOfSent
	"Selects all method removal for sent methods"

	Cursor read showWhile: [
		1 to: changeList size do: [ :i | | change |
			change _ changeList at: i.
			listSelections at: i put:
				(change type = #doIt and: [
					change string includesSubString: 'removeSelector: #' ] and: [
						(Smalltalk allCallsOn: (change string copyAfterLast: $#) asSymbol) size > 0 ]) ]].
	self changed: #allSelections! !


!ClassCommentVersionsBrowser class methodsFor: 'instance creation' stamp: 'jmv 3/1/2010 14:53'!
browseCommentOf: class

	Cursor read showWhile: [ | changeList |
		changeList _ self new scanVersionsOf: class.
	 	changeList ifNil: [^ self inform: 'No versions available'].
		self open: changeList name: 'Recent versions of ',class name,'''s comments' multiSelect: false ]
! !


!Collection methodsFor: 'enumerating' stamp: 'jmv 3/1/2010 15:04'!
count: aBlock
	"Evaluate aBlock with each of the receiver's elements as the argument.  Return the number that answered true."

	^self inject: 0 into: [ :prevValue :each |
		(aBlock value: each) ifTrue: [ prevValue + each ] ifFalse: [ prevValue ] ]! !

!Collection methodsFor: 'enumerating' stamp: 'jmv 3/1/2010 15:06'!
detectSum: aBlock
	"Evaluate aBlock with each of the receiver's elements as the argument. 
	Return the sum of the answers."

	^self inject: 0 into: [ :prevValue :each | prevValue + (aBlock value: each ) ]! !

!Collection methodsFor: 'enumerating' stamp: 'jmv 3/1/2010 15:06'!
do: elementBlock separatedBy: separatorBlock
	| beforeFirst | 
	"Evaluate the elementBlock for all elements in the receiver,
	and evaluate the separatorBlock between."

	beforeFirst _ true.
	self do: [ :element |
		beforeFirst
			ifTrue: [beforeFirst _ false]
			ifFalse: [separatorBlock value].
		elementBlock value: element]! !

!Collection methodsFor: 'enumerating' stamp: 'jmv 3/1/2010 15:09'!
groupBy: keyBlock having: selectBlock 
	"Like in SQL operation - Split the recievers contents into collections of 
	elements for which keyBlock returns the same results, and return those 
	collections allowed by selectBlock. keyBlock should return an Integer."
	| result |
	result _ PluggableDictionary integerDictionary.
	self do: [ :e |
		(result at: (keyBlock value: e) ifAbsentPut: OrderedCollection new) add: e ].
	^ result select: selectBlock! !


!Bag methodsFor: 'accessing' stamp: 'jmv 3/1/2010 14:42'!
cumulativeCounts
	"Answer with a collection of cumulative percents covered by elements so far."
	| s n |
	s _ self size / 100.0.
	n _ 0.
	^ self sortedCounts asArray collect: [ :a |
		n _ n + a key.
		(n / s roundTo: 0.1) -> a value]! !

!Bag methodsFor: 'accessing' stamp: 'jmv 3/1/2010 14:43'!
size

	^contents inject: 0 into: [ :prevValue :each | prevValue + each ]! !


!Color class methodsFor: 'instance creation' stamp: 'jmv 3/1/2010 15:17'!
fromString: aString
	"for HTML color spec: #FFCCAA or white/black"
	"Color fromString: '#FFCCAA'.
	 Color fromString: 'white'.
	 Color fromString: 'orange'"
	| aColorHex |
	aString isEmptyOrNil ifTrue: [^ Color white].
	aColorHex _ aString first = $#
		ifTrue: [aString copyFrom: 2 to: aString size]
		ifFalse: [aString].
	[
		aColorHex size = 6
			ifTrue: [ | aColorHexU red green blue |
				aColorHexU _ aColorHex asUppercase.
				red _ ('16r', (aColorHexU copyFrom: 1 to: 2)) asNumber/255.
				green _ ('16r', (aColorHexU copyFrom: 3 to: 4)) asNumber/255.
				blue _ ('16r', (aColorHexU copyFrom: 5 to: 6)) asNumber/255.
				^ self r: red g: green b: blue]
	] ifError: [:err :rcvr | "not a hex color triplet" ].
	
	"try to match aColorHex with known named colors"
	aColorHex _ aColorHex asLowercase.

	^self perform: (ColorNames detect: [:i | i asString asLowercase = aColorHex]
		ifNone: [#white])! !

!Color class methodsFor: 'class initialization' stamp: 'jmv 3/1/2010 15:18'!
initializeTranslucentPatterns
	"Color initializeTranslucentPatterns"

	TranslucentPatterns _ Array new: 8.
	#(1 2 4 8) do: [ :d | | mask bits pattern patternList |
		patternList _ Array new: 5.
		mask _ (1 bitShift: d) - 1.
		bits _ 2 * d.
		[bits >= 32] whileFalse: [
			mask _ mask bitOr: (mask bitShift: bits).  "double the length of mask"
			bits _ bits + bits].
		"0% pattern"
		pattern _ Bitmap with: 0 with: 0.
		patternList at: 1 put: pattern.
		"25% pattern"
		pattern _ Bitmap with: mask with: 0.
		patternList at: 2 put: pattern.
		"50% pattern"
		pattern _ Bitmap with: mask with: mask bitInvert32.
		patternList at: 3 put: pattern.
		"75% pattern"
		pattern _ Bitmap with: mask with: 16rFFFFFFFF.
		patternList at: 4 put: pattern.
		"100% pattern"
		pattern _ Bitmap with: 16rFFFFFFFF with: 16rFFFFFFFF.
		patternList at: 5 put: pattern.
		TranslucentPatterns at: d put: patternList.
	].! !

!Color class methodsFor: 'colormaps' stamp: 'jmv 3/1/2010 15:15'!
computeIndexedColorConvertingMap: targetColor from: sourceDepth to: destDepth
	| map |
	
	map _ (IndexedColors copyFrom: 1 to: (1 bitShift: sourceDepth)) collect: [ :cc | | f c |
		f _ 1.0 - (cc red + cc green + cc blue / 3.0 ).
		c _ targetColor
			ifNotNil: [
				destDepth = 32
					ifTrue: [ targetColor * f alpha: f]
					ifFalse: [ targetColor alphaMixed: f*1.5 with: Color white ]]
			ifNil: [ cc ].
		destDepth = 32
			ifTrue: [ c pixelValueForDepth: destDepth]
			ifFalse: [
				f = 0.0
					ifTrue: [ 0 ]
					ifFalse: [ c pixelValueForDepth: destDepth ]]].
	map _ map as: Bitmap.
	^map! !

!Color class methodsFor: 'color from user' stamp: 'jmv 3/1/2010 15:13'!
colorPaletteForDepth: depth extent: chartExtent
	"Display a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively."
	"Note: It is slow to build this palette, so it should be cached for quick access."
	"(Color colorPaletteForDepth: 16 extent: 190@60) display"

	| basicHue x y startHue palette transHt vSteps transCaption grayWidth hSteps |
	palette _ Form extent: chartExtent depth: depth.
	transCaption _ 
		(Form extent: 34@9 depth: 1
			fromArray: #(0 0 256 0 256 0 3808663859 2147483648 2491688266 2147483648 2491688266 0 2491688266 0 2466486578 0 0 0)
			offset: 0@0).
	transHt _ transCaption height.
	palette fillWhite: (0@0 extent: palette width@transHt).
	palette fillBlack: (0@transHt extent: palette width@1).
	transCaption displayOn: palette at: palette boundingBox topCenter - ((transCaption width // 2)@0).
	grayWidth _ 10.
	startHue _ 338.0.
	vSteps _ palette height - transHt // 2.
	hSteps _ palette width - grayWidth.
	x _ 0.
	startHue to: startHue + 360.0 by: 360.0/hSteps do: [ :h |
		basicHue _ Color h: h asFloat s: 1.0 v: 1.0.
		y _ transHt+1.
		0 to: vSteps do: [ :n | | c |
 			c _ basicHue mixed: (n asFloat / vSteps asFloat) with: Color white.
			palette fill: (x@y extent: 1@1) fillColor: c.
			y _ y + 1].
		1 to: vSteps do: [ :n | | c |
 			c _ Color black mixed: (n asFloat / vSteps asFloat) with: basicHue.
			palette fill: (x@y extent: 1@1) fillColor: c.
			y _ y + 1].
		x _ x + 1].
	y _ transHt + 1.
	1 to: vSteps * 2 do: [ :n | | c |
 		c _ Color black mixed: (n asFloat / (vSteps*2) asFloat) with: Color white.
		palette fill: (x@y extent: 10@1) fillColor: c.
		y _ y + 1].
	^ palette
! !


!ColorPickerMorph methodsFor: 'accessing' stamp: 'jmv 3/1/2010 15:19'!
locationIndicator

	^self valueOfProperty: #locationIndicator ifAbsent: [
		| loc |
		loc _ EllipseMorph new.
		loc color: Color transparent; 
			borderWidth: 1; 
			borderColor: Color red; 
			extent: 6@6.
		self setProperty: #locationIndicator toValue: loc.
		self addMorphFront: loc.
		loc]! !

!ColorPickerMorph methodsFor: 'other' stamp: 'jmv 3/1/2010 15:19'!
putUpFor: aMorph near: aRectangle
	"Put the receiver up on the screen.   Note highly variant behavior depending on the setting of the #modalColorPickers preference"
	| layerNumber |
	(aMorph is: #Morph) ifTrue: [
		layerNumber _ aMorph morphicLayerNumber.
		aMorph allOwnersDo: [ : m|
			layerNumber _ layerNumber min: m morphicLayerNumber].
		self setProperty: #morphicLayerNumber toValue: layerNumber - 0.1
	].

	isModal == true "backward compatibility"
		ifTrue: [
			self pickUpColorFor: aMorph]
		ifFalse: [
			self addToWorld:
				((aMorph notNil and: [aMorph world notNil])
					ifTrue:
						[aMorph world]
					ifFalse:
						[self currentWorld])
		  		near:
					(aRectangle ifNil:
						[aMorph ifNil: [100@100 extent: 1@1] ifNotNil: [aMorph fullBoundsInWorld]])]! !


!CompiledMethod methodsFor: 'accessing' stamp: 'jmv 3/1/2010 15:21'!
searchForSelector
	"search me in all classes, if found, return my selector. Slow!!"

	Smalltalk allBehaviorsDo: [:class | 
		(class methodDict keyAtIdentityValue: self ifAbsent: [nil]) ifNotNil: [ :selector | ^selector]].
	^nil! !

!CompiledMethod methodsFor: 'testing' stamp: 'jmv 3/1/2010 15:20'!
hasReportableSlip
	"Answer whether the receiver contains anything that should be brought 
	to the attention of the author when filing out. Customize the lists here 
	to suit your preferences. If slips do not get reported in spite of your 
	best efforts here, make certain that the Preference 'checkForSlips' is set 
	to true."

	#(#doOnlyOnce: #halt #halt: #hottest #printDirectlyToDisplay #toRemove #personal #urgent  #haltOnce #haltOnce: #haltIf: )
		do: [ :aLit | 
			(self hasLiteral: aLit)
				ifTrue: [^ true]].
	#(#Transcript #AA #BB #CC #DD #EE )
		do: [ :aSymbol | 	| assoc |
			(assoc := Smalltalk
				associationAt: aSymbol
				ifAbsent: [])
					ifNotNil: [(self hasLiteral: assoc)
						ifTrue: [^ true]]].
	^ false! !

!CompiledMethod methodsFor: 'printing' stamp: 'jmv 3/1/2010 15:22'!
timeStamp
	"Answer the authoring time-stamp for the given method, retrieved from the sources or changes file. Answer the empty string if no time stamp is available."

	"(CompiledMethod compiledMethodAt: #timeStamp) timeStamp"

	| file preamble stamp tokens tokenCount |
	self fileIndex = 0 ifTrue: [^ String new].  "no source pointer for this method"
	file := SourceFiles at: self fileIndex.
	file ifNil: [^ String new].  "sources file not available"
	"file does not exist happens in secure mode"
	file := [file readOnlyCopy] on: FileDoesNotExistException do:[:ex| nil].
	file ifNil: [^ String new].
	preamble := self getPreambleFrom: file at: (0 max: self filePosition - 3).
	stamp := String new.
	tokens := (preamble findString: 'methodsFor:' startingAt: 1) > 0
		ifTrue: [Scanner new scanTokens: preamble]
		ifFalse: [Array new  "ie cant be back ref"].
	(((tokenCount := tokens size) between: 7 and: 8) and: [(tokens at: tokenCount - 5) = #methodsFor:])
		ifTrue:
			[(tokens at: tokenCount - 3) = #stamp:
				ifTrue: ["New format gives change stamp and unified prior pointer"
						stamp := tokens at: tokenCount - 2]].
	((tokenCount between: 5 and: 6) and: [(tokens at: tokenCount - 3) = #methodsFor:])
		ifTrue:
			[(tokens at: tokenCount  - 1) = #stamp:
				ifTrue: ["New format gives change stamp and unified prior pointer"
					stamp := tokens at: tokenCount]].
	file close.
	^ stamp! !


!ConnectionQueue methodsFor: 'public' stamp: 'jmv 3/1/2010 15:23'!
connectionCount
	"Return an estimate of the number of currently queued connections. This is only an estimate since a new connection could be made, or an existing one aborted, at any moment."

	self pruneStaleConnections.
	^accessSema critical: [connections size]
! !

