'From Cuis 1.0 of 28 November 2009 [latest update: #337] on 30 December 2009 at 10:06:39 pm'!

!BlockClosure commentStamp: '<historical>' prior: 0!
I am a block closure for Eliot's closure implementation. Not to be confused with the old BlockClosure (they were never part of Cuis anyway).!


!Categorizer methodsFor: 'accessing' stamp: 'jmv 12/29/2009 14:30'!
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 ii 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 |
			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].! !


!DependentsArray methodsFor: 'copying' stamp: 'jmv 12/29/2009 14:31'!
size
	^self inject: 0 into: [ :count :dep |
		dep
			ifNil: [ count ]
			ifNotNil: [ count + 1 ]]! !


!ImageSegment methodsFor: 'read/write segment' stamp: 'jmv 12/30/2009 11:01'!
copyFromRoots: aRootArray sizeHint: segSizeHint areUnique: areUnique
	"Copy a tree of objects into a WordArray segment.  The copied objects in the segment are not in the normal Squeak space.  
	[1] For exporting a project.  Objects were enumerated by ReferenceStream and aRootArray has them all.
	[2] For exporting some classes.  See copyFromRootsForExport:. (Caller must hold Symbols, or they will not get registered in the target system.)
	[3] For 'local segments'.  outPointers are kept in the image.
	If this method yields a very small segment, it is because objects just below the roots are pointed at from the outside.  (See findRogueRootsImSeg: for a *destructive* diagnostic of who is pointing in.)"
	| segmentWordArray outPointerArray segSize rootSet uniqueRoots |
	aRootArray ifNil: [self errorWrongState].
	uniqueRoots _ areUnique 
		ifTrue: [aRootArray]
		ifFalse: [rootSet _ IdentitySet new: aRootArray size * 3.
			uniqueRoots _ OrderedCollection new.
			1 to: aRootArray size do: [:ii |	"Don't include any roots twice"
				(rootSet includes: (aRootArray at: ii)) 
					ifFalse: [
						uniqueRoots addLast: (aRootArray at: ii).
						rootSet add: (aRootArray at: ii)]
					ifTrue: [userRootCnt ifNotNil: ["adjust the count"
								ii <= userRootCnt ifTrue: [userRootCnt _ userRootCnt - 1]]]].
			uniqueRoots].
	arrayOfRoots _ uniqueRoots asArray.
	rootSet _ uniqueRoots _ nil.	"be clean"
	userRootCnt ifNil: [userRootCnt _ arrayOfRoots size].
	arrayOfRoots do: [ :aRoot | 
		aRoot indexIfCompact > 0 ifTrue: [
			self error: 'Compact class ', aRoot name, ' cannot be a root'].
		"This used to be needed, as old BlockContext kept referencing to the last value of the arguments.
		This is no longer true with Eliot's BlockClosures, and asigning to block args is discouraged, 
		and perhaps not supported (see preference #allowBlockArgumentAssignment)"
		"aRoot _ nil"		"clean up"
		].
	outPointers _ nil.	"may have used this instance before"
	segSize _ segSizeHint > 0 ifTrue: [segSizeHint *3 //2] ifFalse: [50000].

	["Guess a reasonable segment size"
	segmentWordArray _ WordArrayForSegment new: segSize.
	[ outPointerArray _ Array new: segSize // 20 ] ifError: [
		state _ #tooBig.  ^ self].
	"Smalltalk garbageCollect."
	(self storeSegmentFor: arrayOfRoots
					into: segmentWordArray
					outPointers: outPointerArray) == nil]
		whileTrue: [
			"Double the segment size and try again"
			segmentWordArray _ outPointerArray _ nil.
			segSize _ segSize * 2].
	segment _ segmentWordArray.
	outPointers _ outPointerArray.
	state _ #activeCopy.
	endMarker _ segment nextObject. 	"for enumeration of objects"
	endMarker == 0 ifTrue: [endMarker _ 'End' clone].
! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'jmv 12/30/2009 11:02'!
rootsIncludingBlockMethods
	"Return a new roots array with more objects.  (Caller should store into rootArray.) Any CompiledMethods that create blocks will be in outPointers if the block is held outside of this segment.  Put such methods into the roots list.  Then ask for the segment again."

| extras myClasses gotIt |
userRootCnt ifNil: [userRootCnt _ arrayOfRoots size].
extras _ OrderedCollection new.
myClasses _ OrderedCollection new.
arrayOfRoots do: [:aRoot | aRoot class class == Metaclass ifTrue: [
					myClasses add: aRoot]].
myClasses isEmpty ifTrue: [^ nil].	"no change"
outPointers do: [ :anOut | 
	anOut class == CompiledMethod ifTrue: [
		"specialized version of who"
		gotIt _ false.
		myClasses detect: [:class |
			class selectorsDo: [:sel |
				(class compiledMethodAt: sel) == anOut 
					ifTrue: [extras add: anOut.  gotIt _ true]].
			gotIt] 
			ifNone: []
		].
	"This used to be needed, as old BlockContext kept referencing to the last value of the arguments.
	This is no longer true with Eliot's BlockClosures, and asigning to block args is discouraged, 
	and perhaps not supported (see preference #allowBlockArgumentAssignment)"
	"anOut _ nil"
].
extras _ extras select: [:ea | (arrayOfRoots includes: ea) not].
extras isEmpty ifTrue: [^ nil].	"no change"
^ arrayOfRoots, extras! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'jmv 12/30/2009 11:02'!
rootsIncludingBlocks
	"For export segments only.  Return a new roots array with more objects.  (Caller should store into rootArray.)  Collect Blocks and external methods pointed to by them.  Put them into the roots list.  Then ask for the segment again."

	| extras have |
	userRootCnt ifNil: [userRootCnt := arrayOfRoots size].
	extras := OrderedCollection new.
	outPointers do: [ :anOut | 
		anOut class == CompiledMethod ifTrue: [ extras add: anOut ].
		(anOut isBlock) ifTrue: [extras add: anOut].
		(anOut class == MethodContext) ifTrue: [ extras add: anOut ].
		"This used to be needed, as old BlockContext kept referencing to the last value of the arguments.
		This is no longer true with Eliot's BlockClosures, and asigning to block args is discouraged, 
		and perhaps not supported (see preference #allowBlockArgumentAssignment)"
		"anOut := nil"		"don't hang onto it"
	].

	[
		have := extras size.
		extras copy do: [ :anOut |
			anOut isBlock ifTrue: [
				anOut home ifNotNil: [
					(extras includes: anOut home) ifFalse: [extras add: anOut home]]].
			(anOut class == MethodContext) ifTrue: [
				anOut method ifNotNil: [
					(extras includes: anOut method) ifFalse: [extras add: anOut method]]]].
		have = extras size
	] whileFalse.
	extras := extras select: [:ea | (arrayOfRoots includes: ea) not].
	extras isEmpty ifTrue: [^ nil].	"no change"

	^ arrayOfRoots, extras! !


!Preferences class methodsFor: 'standard queries' stamp: 'jmv 12/29/2009 15:53'!
allowBlockArgumentAssignment
	^ self
		valueOfFlag: #allowBlockArgumentAssignment
		ifAbsent: [false]! !


!String methodsFor: 'converting' stamp: 'jmv 12/29/2009 14:39'!
asPacked
	"Convert to a longinteger that describes the string"
	^ self inject: 0 into: [ :previousValue :each | previousValue * 256 + each asInteger ].! !


!Symbol methodsFor: 'system primitives' stamp: 'jmv 12/29/2009 14:24'!
numArgs: n
	"Answer a string that can be used as a selector with n arguments.
	 TODO: need to be extended to support shrinking and for selectors like #+ " 

	| selector numArgs aStream offs |
	
	selector _ self.
	(numArgs _ selector numArgs) >= n ifTrue: [ ^self ].	
	aStream _ WriteStream on: (String new: 16).
	aStream nextPutAll: self.
	
	(numArgs = 0) ifTrue: [ aStream nextPutAll: ':'. offs _ 0 ] ifFalse: [offs _ 1].
	2 to: n - numArgs + offs do: [ :i | aStream nextPutAll: 'with:' ].	
	^aStream contents asSymbol! !

!Symbol methodsFor: 'testing' stamp: 'jmv 12/29/2009 15:49'!
isDoIt

	^ (self == #DoIt) or: [self == #DoItIn:]! !


!TextEditor methodsFor: 'editing keys' stamp: 'jmv 12/29/2009 14:42'!
inOutdent: aKeyboardEvent delta: delta
	"Add/remove a tab at the front of every line occupied by the selection. 
	Derived from work by Larry Tesler back in December 1985.  Now triggered by Cmd-L and Cmd-R.  2/29/96 sw"

	| cr realStart realStop lines startLine stopLine start stop adjustStart indentation size numLines inStream newString outStream |
	cr _ Character cr.

	"Operate on entire lines, but remember the real selection for re-highlighting later"
	realStart _ self startIndex.
	realStop _ self stopIndex - 1.

	"Special case a caret on a line of its own, including weird case at end of paragraph"
	(realStart > realStop and: [
				realStart < 2 or: [(paragraph string at: realStart - 1) == cr]])
		ifTrue:
			[delta < 0
				ifTrue: [
					morph flash]
				ifFalse: [
					self replaceSelectionWith: Character tab asSymbol asText.
					self selectAt: realStart + 1].
			^true].

	lines _ paragraph lines.
	startLine _ paragraph lineIndexOfCharacterIndex: realStart.
	stopLine _ paragraph lineIndexOfCharacterIndex: (realStart max: realStop).
	start _ (lines at: startLine) first.
	stop _ (lines at: stopLine) last.
	
	"Pin the start of highlighting unless the selection starts a line"
	adjustStart _ realStart > start.

	"Find the indentation of the least-indented non-blank line; never outdent more"
	indentation _ (startLine to: stopLine) inject: 1000 into: [ :previousValue :each |
		previousValue min: (paragraph indentationOfLineIndex: each ifBlank: [ :tabs | 1000 ])].			

	size _  stop + 1 - start.
	numLines _ stopLine + 1 - startLine.
	inStream _ ReadStream on: paragraph string from: start to: stop.

	newString _ String new: size + ((numLines * delta) max: 0).
	outStream _ ReadWriteStream on: newString.

	"This subroutine does the actual work"
	self indent: delta fromStream: inStream toStream: outStream.

	"Adjust the range that will be highlighted later"
	adjustStart ifTrue: [realStart _ (realStart + delta) max: start].
	realStop _ realStop + outStream position - size.

	"Prepare for another iteration"
	indentation _ indentation + delta.
	size _ outStream position.
	inStream _ outStream setFrom: 1 to: size.

	outStream == nil
		ifTrue: 	"tried to outdent but some line(s) were already left flush"
			[morph flash]
		ifFalse:
			[self selectInvisiblyFrom: start to: stop.
			size = newString size ifFalse: [newString _ outStream contents].
			self replaceSelectionWith: newString asText].
	self selectFrom: realStart to: realStop. 	"highlight only the original range"
	^ true! !


!Utilities class methodsFor: 'common requests' stamp: 'jmv 12/29/2009 14:44'!
offerCommonRequestsInMorphic
	"Offer up the common-requests menu.  If the user chooses one, then evaluate it, and -- provided the value is a number or string -- show it in the Transcript."

	"Utilities offerCommonRequests"

	| aMenu strings aString |
	(CommonRequestStrings == nil or: [CommonRequestStrings isKindOf: Array]) 
		ifTrue: [self initializeCommonRequestStrings].
	strings := CommonRequestStrings contents.
	aMenu := MenuMorph new.
	aMenu title: 'Common Requests' translated.
	aMenu addStayUpIcons.
	strings asString linesDo: [ :each | 
		aString _ each.
		aString = '-' 
			ifTrue: [ aMenu addLine ]
			ifFalse: [
				aString size = 0 ifTrue: [ aString := ' ' ].
				aMenu 
					add: aString
					target: self
					selector: #eval:
					argument: aString]].
	aMenu addLine.
	aMenu 
		add: 'edit this list' translated
		target: self
		action: #editCommonRequestStrings.
	aMenu popUpInWorld: self currentWorld! !

!Utilities class methodsFor: 'closure support' stamp: 'jmv 12/29/2009 15:32'!
postRecompileCleanup	"Utilities postRecompileCleanup"
	"Cleanup after loading closure bootstrap"
	| unboundMethods contexts |
	World removeAllKnownFailing.
	ProcessorScheduler startUp.
	WeakArray restartFinalizationProcess.
	MethodChangeRecord allInstancesDo:[:x| x noteNewMethod: nil].
	Undeclared removeUnreferencedKeys.
	Delay startTimerEventLoop.
	EventSensor install.
	WorldState allInstancesDo:[:ws| ws convertAlarms; convertStepList].
	(Workspace canUnderstand: #initializeBindings) 
		ifTrue:[Workspace allInstancesDo:[:ws| ws initializeBindings]].
	Smalltalk garbageCollect.
	Smalltalk
		at: #DebuggerMethodMap
		ifPresent: [:dmm| dmm voidMapCache].
	(ProcessBrowser respondsTo: #registerWellKnownProcesses) ifTrue:
		[ProcessBrowser registerWellKnownProcesses].
	Smalltalk
		at: #DebuggerMethodMap
		ifPresent: [:dmm| dmm voidMapCache].
	Smalltalk at: #ServiceRegistry ifPresent:[:cls| cls rebuild].
	Smalltalk forgetDoIts.
	Smalltalk garbageCollect.
	unboundMethods := CompiledMethod allInstances select:[:m|
		m methodClass isNil or: [m ~~ (m methodClass compiledMethodAt: m selector ifAbsent: nil)]].
	unboundMethods := unboundMethods reject:[:m| m selector isDoIt].
	unboundMethods notEmpty ifTrue:
		[unboundMethods inspectWithLabel: 'Unbound Methods'].
	contexts := BlockContext allInstances.
	contexts ifNotEmpty:[contexts inspect. self inform: 'There are left-over BlockContexts'].
	(unboundMethods isEmpty and:[contexts isEmpty]) ifTrue:[
		self inform:'Congratulations - The bootstrap is now complete.'.
	].
! !


!WeakArray class methodsFor: 'private' stamp: 'jmv 12/30/2009 11:03'!
finalizationProcess

	[true] whileTrue:
		[FinalizationSemaphore wait.
		FinalizationLock critical:
			[FinalizationDependents do:
				[:weakDependent |
				weakDependent ifNotNil:
					[weakDependent finalizeValues.
					
					"***Following statement is required to keep weakDependent
					from holding onto its value as garbage.***"
					
					"This used to be needed, as old BlockContext kept referencing to the last value of the arguments.
					This is no longer true with Eliot's BlockClosures, and asigning to block args is discouraged, 
					and perhaps not supported (see preference #allowBlockArgumentAssignment)"
					
					"weakDependent _ nil"]]]
			ifError:
			[:msg :rcvr | rcvr error: msg].
		].
! !


!WorldState methodsFor: 'alarms' stamp: 'jmv 12/30/2009 11:06'!
alarmSortBlock

	"Please pardon the hackery below. Since the block provided by this method is retained elsewhere, it is possible that the block argument variables would retain references to objects that were no longer really needed. In one case, this feature resulted in doubling the size of a published project."
"
	| answer |
	^[ :alarm1 :alarm2 | 
		answer _ alarm1 scheduledTime < alarm2 scheduledTime.
		alarm1 _ alarm2 _ nil.
		answer
	]
"

	"This used to be needed, as old BlockContext kept referencing to the last value of the arguments.
	This is no longer true with Eliot's BlockClosures, and asigning to block args is discouraged, 
	and perhaps not supported (see preference #allowBlockArgumentAssignment)"

	^[ :alarm1 :alarm2 | alarm1 scheduledTime < alarm2 scheduledTime ]! !

!WorldState methodsFor: 'initialization' stamp: 'jmv 12/30/2009 11:08'!
stepListSortBlock

	"Please pardon the hackery below. Since the block provided by this method is retained elsewhere, it is possible that the block argument variables would retain references to objects that were no longer really needed. In one case, this feature resulted in doubling the size of a published project."
"
	| answer |
	^[ :stepMsg1 :stepMsg2 | 
		answer _ stepMsg1 scheduledTime <= stepMsg2 scheduledTime.
		stepMsg1 _ stepMsg2 _ nil.
		answer
	]
"

	"This used to be needed, as old BlockContext kept referencing to the last value of the arguments.
	This is no longer true with Eliot's BlockClosures, and asigning to block args is discouraged, 
	and perhaps not supported (see preference #allowBlockArgumentAssignment)"

	^[ :stepMsg1 :stepMsg2 | stepMsg1 scheduledTime <= stepMsg2 scheduledTime ]! !

!WorldState methodsFor: 'object fileIn' stamp: 'jmv 12/29/2009 15:18'!
convertAlarms
	
	alarms ifNotNil: [alarms sortBlock: self alarmSortBlock].	"ensure cleaner block"! !

!WorldState methodsFor: 'object fileIn' stamp: 'jmv 12/29/2009 15:20'!
convertStepList
	"Convert the old-style step list (an Array of Arrays) into the new-style StepMessage heap"

	stepList sortBlock: self stepListSortBlock	"ensure that we have a cleaner block"! !

