'From Cuis 1.0 of 28 November 2009 [latest update: #337] on 7 December 2009 at 6:17 pm'!

!Array methodsFor: 'converting' stamp: 'jmv 12/7/2009 17:25'!
evalStrings
	   "Allows you to construct literal arrays.
    #(true false nil '5@6' 'Set new' '''text string''') evalStrings
    gives an array with true, false, nil, a Point, a Set, and a String
    instead of just a bunch of Symbols"
    | it |

    ^ self collect: [:each |
        it _ each.
        each == #true ifTrue: [it _ true].
		      each == #false ifTrue: [it _ false].
        each == #nil ifTrue: [it _ nil].
        each class == String ifTrue: [
			it _ Smalltalk actualCompilerClass evaluate: each].
        each class == Array ifTrue: [it _ it evalStrings].
        it]! !


!Behavior methodsFor: 'accessing' stamp: 'jmv 12/7/2009 17:26'!
compilerClass
	"Answer a compiler class appropriate for source methods of this class."

	^Smalltalk actualCompilerClass! !

!Behavior methodsFor: 'accessing' stamp: 'jmv 12/7/2009 17:52'!
decompilerClass
	"Answer a decompiler class appropriate for compiled methods of this class."

	^Smalltalk actualDecompilerClass! !

!Behavior methodsFor: 'accessing' stamp: 'jmv 12/7/2009 17:31'!
evaluatorClass
	"Answer an evaluator class appropriate for evaluating expressions in the 
	context of this class."

	^Smalltalk actualCompilerClass! !

!Behavior methodsFor: 'accessing' stamp: 'jmv 12/7/2009 17:31'!
subclassDefinerClass
	"Answer an evaluator class appropriate for evaluating definitions of new 
	subclasses of this class."

	^Smalltalk actualCompilerClass! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'jmv 12/7/2009 17:39'!
"popeye" formalHeaderPartsFor: "olive oil" aSelector
	"RELAX!!  The warning you may have just seen about possibly having a bad source file does not apply here, because this method *intends* to have its source code start with a comment.
	This method returns a collection giving the parts in the formal declaration for aSelector.  This parse is in support of schemes in which adjutant properties of a method can be declared via special comments secreted in the formal header
	The result will have
     	3 elements for a simple, argumentless selector.
		5 elements for a single-argument selector
		9 elements for a two-argument selector
		13 elements for a three-argument, selector
		etc...

	The syntactic elements are:

		1		comment preceding initial selector fragment

		2		first selector fragment
		3		comment following first selector fragment  (nil if selector has no arguments)

        ----------------------  (ends here for, e.g., #copy)

		4		first formal argument
		5		comment following first formal argument (nil if selector has only one argument)

        ----------------------  (ends here for, e.g., #copyFrom:)

		6		second keyword
		7		comment following second keyword
		8		second formal argument
		9		comment following second formal argument (nil if selector has only two arguments)

         ----------------------  (ends here for, e.g., #copyFrom:to:)

	Any nil element signifies an absent comment.
	NOTE: The comment following the final formal argument is *not* successfully retrieved by this method in its current form, though it can be obtained, if needed, by other means (e.g. calling #firstPrecodeCommentFor:).  Thus, the *final* element in the structure returned by this method is always going to be nil."

	^ Smalltalk actualScannerClass new scanMessageParts: (self methodHeaderFor: aSelector)

"
	Behavior class formalHeaderPartsFor: #formalHeaderPartsFor:
"


	! !

!Behavior methodsFor: 'private' stamp: 'jmv 12/7/2009 18:05'!
basicCompile: code notifying: requestor trailer: bytes ifFail: failBlock
	"Compile code without logging the source in the changes file"

	| methodNode |
	methodNode _ self compilerClass new
				compile: code
				in: self
				notifying: requestor
				ifFail: failBlock.
	methodNode encoder requestor: requestor.
	^ Smalltalk actualCompiledMethodWithNodeClass generateMethodFromNode: methodNode trailer: bytes.! !


!Browser methodsFor: 'class functions' stamp: 'jmv 12/7/2009 17:24'!
copyClass
	| originalName copysName class oldDefinition newDefinition |
	
	classListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	originalName _ self selectedClass name.
	copysName _ self request: 'Please type new class name' initialAnswer: originalName.
	copysName = '' ifTrue: [^ self].  " Cancel returns '' "
	copysName _ copysName asSymbol.
	copysName = originalName ifTrue: [^ self].
	(Smalltalk includesKey: copysName)
		ifTrue: [^ self error: copysName , ' already exists'].
	oldDefinition _ self selectedClass definition.
	newDefinition _ oldDefinition copyReplaceAll: '#' , originalName asString with: '#' , copysName asString.
	Cursor wait 
		showWhile: [
			class _ Smalltalk actualCompilerClass evaluate: newDefinition logged: true.
			class copyAllCategoriesFrom: (Smalltalk at: originalName).
			class class copyAllCategoriesFrom: (Smalltalk at: originalName) class ].
	self classListIndex: 0.
	self changed: #classList! !

!Browser methodsFor: 'message functions' stamp: 'jmv 12/7/2009 17:35'!
defineMessageFrom: aString notifying: aController
	"Compile the expressions in aString. Notify aController if a syntax error occurs. Install the compiled method in the selected class classified under  the currently selected message category name. Answer the selector obtained if compilation succeeds, nil otherwise."
	| selectedMessageName selector category oldMessageList |
	selectedMessageName _ self selectedMessageName.
	oldMessageList _ self messageList.
	contents _ nil.
	selector _ (Smalltalk actualParserClass new parseSelector: aString).
	(self metaClassIndicated
		and: [(self selectedClassOrMetaClass includesSelector: selector) not
		and: [Metaclass isScarySelector: selector]])
		ifTrue: ["A frist-time definition overlaps the protocol of Metaclasses"
				(self confirm: ((selector , ' is used in the existing class system.
Overriding it could cause serious problems.
Is this really what you want to do?') asText makeBoldFrom: 1 to: selector size))
				ifFalse: [^nil]].
	selector _ self selectedClassOrMetaClass
				compile: aString
				classified: (category _ self selectedMessageCategoryName)
				notifying: aController.
	selector == nil ifTrue: [^ nil].
	contents _ aString copy.
	selector ~~ selectedMessageName
		ifTrue: 
			[category = ClassOrganizer nullCategory
				ifTrue: [self changed: #classSelectionChanged.
						self changed: #classList.
						self messageCategoryListIndex: 1].
			self setClassOrganizer.  "In case organization not cached"
			(oldMessageList includes: selector)
				ifFalse: [self changed: #messageList].
			self messageListIndex: (self messageList indexOf: selector)].
	^ selector! !


!Categorizer methodsFor: 'accessing' stamp: 'jmv 12/7/2009 17:40'!
changeFromString: aString 
	"Parse the argument, aString, and make this be the receiver's structure."

	| categorySpecs |
	categorySpecs _ Smalltalk actualScannerClass new scanTokens: aString.
	"If nothing was scanned and I had no elements before, then default me"
	(categorySpecs isEmpty and: [elementArray isEmpty])
		ifTrue: [^ self setDefaultList: Array new].

	^ self changeFromCategorySpecs: categorySpecs! !


!ChangeList methodsFor: 'scanning' stamp: 'jmv 12/7/2009 17:40'!
scanCategory
	"Scan anything that involves more than one chunk; method name is historical only"

	| itemPosition item tokens stamp isComment anIndex def isMeta name record |
	itemPosition _ file position.
	item _ file nextChunk.

	isComment _ (item includesSubString: 'commentStamp:').
	(isComment or: [item includesSubString: 'methodsFor:'] or: [item includesSubString: 'classDefinition:']) ifFalse: [
		"Maybe a preamble, but not one we recognize; bail out with the preamble trick"
		^ self addItem: (ChangeRecord new file: file position: itemPosition type: #preamble)
				 text: ('preamble: ' , item contractTo: 160)].

	tokens _ Smalltalk actualScannerClass new scanTokens: item.
	tokens size >= 3 ifTrue: [
		stamp _ ''.
		anIndex _ tokens indexOf: #stamp: ifAbsent: [nil].
		anIndex ifNotNil: [stamp _ tokens at: (anIndex + 1)].

		tokens first == #classDefinition:
			ifTrue: [
				itemPosition _ file position.
				isMeta _ tokens second includesSubString: ' class'.
				name _ isMeta ifTrue: [tokens second substrings first] ifFalse: [tokens second].
				def _ file nextChunk.
				record _ ChangeRecord new file: file position: itemPosition type: #classDefinition
					class: name asSymbol category: tokens last meta: isMeta stamp: nil.
				self addItem: record text: 'classDefinition: ', def.
				^file skipStyleChunk].
		
		tokens second == #methodsFor:
			ifTrue: [^ self scanCategory: tokens third class: tokens first
							meta: false stamp: stamp].

		tokens third == #methodsFor:
			ifTrue: [^ self scanCategory: tokens fourth class: tokens first
							meta: true stamp: stamp]].

	tokens second == #commentStamp:
		ifTrue:
			[stamp _ tokens third.
			self addItem:
					(ChangeRecord new file: file position: file position type: #classComment
									class: tokens first category: nil meta: false stamp: stamp)
					text: 'class comment for ' , tokens first, 
						  (stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp]).
			file nextChunk.
			^ file skipStyleChunk]! !

!ChangeList methodsFor: 'scanning' stamp: 'jmv 12/7/2009 17:35'!
scanCategory: category class: class meta: meta stamp: stamp
	| itemPosition method |
	[itemPosition _ file position.
	method _ file nextChunk.
	file skipStyleChunk.
	method size > 0]						"done when double terminators"
		whileTrue:
		[self addItem: (ChangeRecord new file: file position: itemPosition type: #method
							class: class category: category meta: meta stamp: stamp)
			text: 'method: ' , class , (meta ifTrue: [' class '] ifFalse: [' '])
				, (Smalltalk actualParserClass new parseSelector: method)
				, (stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp])]! !

!ChangeList methodsFor: 'menu actions' stamp: 'jmv 12/7/2009 17:25'!
selectSuchThat
	"query the user for a selection criterio.  By Lex Spoon.  NB: the UI for invoking this from a changelist browser is currently commented out; to reenfranchise it, you'll need to mild editing to ChangeList method #changeListMenu:"
	| code block |
	code _ FillInTheBlank request: 'selection criteria for a change named aChangeRecord?\For instance, ''aChangeRecord category = ''System-Network''''' withCRs.

	code isEmpty ifTrue: [^ self ].

	block _ Smalltalk actualCompilerClass evaluate: '[:aChangeRecord | ', code, ']'.

	self selectSuchThat: block! !


!ChangeRecord methodsFor: 'access' stamp: 'jmv 12/7/2009 17:35'!
methodSelector
	type == #method ifFalse: [^ nil].
	^ Smalltalk actualParserClass new parseSelector: self string! !

!ChangeRecord methodsFor: 'access' stamp: 'jmv 12/7/2009 17:40'!
readStamp
	"Get the time stamp of this method off the file"

	| item tokens anIndex |
	stamp _ ''.
	file ifNil: [^ stamp].
	file position: position.
	item _ file nextChunk.
	tokens _ Smalltalk actualScannerClass new scanTokens: item.
	tokens size < 3 ifTrue: [^ stamp].
	anIndex _ tokens indexOf: #stamp: ifAbsent: [^ stamp].
	^ stamp _ tokens at: (anIndex + 1).
! !

!ChangeRecord methodsFor: 'initialization' stamp: 'jmv 12/7/2009 17:23'!
fileIn
	"File the receiver in.  If I represent a method or a class-comment, file the method in and make a note of it in the recent-submissions list; if I represent a do-it, then, well, do it."
	| methodClass s aSelector |
	Cursor read showWhile:
		[(methodClass _ self methodClass) notNil ifTrue:
			[methodClass compile: self text classified: category withStamp: stamp notifying: nil.
			(aSelector _ self methodSelector) ifNotNil:
				[Utilities noteMethodSubmission: aSelector forClass: methodClass]].
		(type == #doIt) ifTrue:
			[((s _ self string) beginsWith: '----') ifFalse: [Smalltalk actualCompilerClass evaluate: s]].
		(type == #classDefinition) ifTrue: [
			Smalltalk actualCompilerClass evaluate: self string].
		(type == #classComment) ifTrue:
			[ | cls | (cls _ Smalltalk at: class asSymbol) comment: self text stamp: stamp.
			Utilities noteMethodSubmission: #Comment forClass: cls ]]! !


!ChangeSorter methodsFor: 'code pane' stamp: 'jmv 12/7/2009 17:41'!
contents: aString notifying: aController 
	"Compile the code in aString. Notify aController of any syntax errors. 
	Create an error if the category of the selected message is unknown. 
	Answer false if the compilation fails. Otherwise, if the compilation 
	created a new method, deselect the current selection. Then answer true."
	| category selector class oldSelector |

	(class _ self selectedClassOrMetaClass) ifNil:
		[(myChangeSet preambleString == nil or: [aString size = 0]) ifTrue: [ ^ false].
		(aString count: [:char | char == $"]) odd 
			ifTrue: [self inform: 'unmatched double quotes in preamble']
			ifFalse: [(Smalltalk actualScannerClass new scanTokens: aString) size > 0 ifTrue: [
				self inform: 'Part of the preamble is not within double-quotes.
To put a double-quote inside a comment, type two double-quotes in a row.
(Ignore this warning if you are including a doIt in the preamble.)']].
		myChangeSet preambleString: aString.
		self currentSelector: nil.  "forces update with no 'unsubmitted chgs' feedback"
		^ true].
	oldSelector _ self selectedMessageName.
	category _ class organization categoryOfElement: oldSelector.
	selector _ class compile: aString
				classified: category
				notifying: aController.
	selector ifNil: [^ false].
	(self messageList includes: selector)
		ifTrue: [self currentSelector: selector]
		ifFalse: [self currentSelector: oldSelector].
	self update.
	^ true! !


!ClassBuilder methodsFor: 'class definition' stamp: 'jmv 12/7/2009 17:41'!
class: oldClass instanceVariableNames: instVarString unsafe: unsafe
	"This is the basic initialization message to change the definition of
	an existing Metaclass"
	| instVars newClass needNew copyOfOldClass |
	instVars _ Smalltalk actualScannerClass new scanFieldNames: instVarString.
	unsafe ifFalse:[
		"Run validation checks so we know that we have a good chance for recompilation"
		(self validateInstvars: instVars from: oldClass forSuper: oldClass superclass) ifFalse:[^nil].
		(self validateSubclassFormat: oldClass typeOfClass from: oldClass forSuper: oldClass superclass extra: instVars size) ifFalse:[^nil]].
	"See if we need a new subclass or not"
	needNew _ self needsSubclassOf: oldClass superclass type: oldClass typeOfClass instanceVariables: instVars from: oldClass.
	needNew ifNil:[^nil]. "some error"
	needNew ifFalse:[^oldClass]. "no new class needed"

	"Create the new class"
	copyOfOldClass _ oldClass copy.
	newClass _ self 
		newSubclassOf: oldClass superclass 
		type: oldClass typeOfClass
		instanceVariables: instVars
		from: oldClass.
		
	newClass _ self recompile: false from: oldClass to: newClass mutate: false.
	self doneCompiling: newClass.
	SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfOldClass to: newClass.
	^newClass! !

!ClassBuilder methodsFor: 'class definition' stamp: 'jmv 12/7/2009 17:41'!
name: className subclassOf: newSuper type: type instanceVariableNames: instVarString classVariableNames: classVarString poolDictionaries: poolString category: category unsafe: unsafe
	"Define a new class.
	If unsafe is true do not run any validation checks.
	This facility is provided to implement important system changes."
	| oldClass newClass organization instVars classVars force needNew oldCategory copyOfOldClass newCategory |
	instVars _ Smalltalk actualScannerClass new scanFieldNames: instVarString.
	classVars _ (Smalltalk actualScannerClass new scanFieldNames: classVarString) collect: [:x | x asSymbol].

	"Validate the proposed name"
	unsafe ifFalse:[(self validateClassName: className) ifFalse:[^nil]].
	oldClass _ Smalltalk at: className ifAbsent:[nil].
	oldClass isBehavior 
		ifFalse:[oldClass _ nil]. "Already checked in #validateClassName:"
	copyOfOldClass _ oldClass copy.

	unsafe ifFalse:[
		"Run validation checks so we know that we have a good chance for recompilation"
		(self validateSuperclass: newSuper forSubclass: oldClass) ifFalse:[^nil].
		(self validateInstvars: instVars from: oldClass forSuper: newSuper) ifFalse:[^nil].
		(self validateClassvars: classVars from: oldClass forSuper: newSuper) ifFalse:[^nil].
		(self validateSubclassFormat: type from: oldClass forSuper: newSuper extra: instVars size) ifFalse:[^nil]].

	"See if we need a new subclass"
	needNew _ self needsSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass.
	needNew == nil ifTrue:[^nil]. "some error"

	(needNew and:[unsafe not]) ifTrue:[
		"Make sure we don't redefine any dangerous classes"
		(self tooDangerousClasses includes: oldClass name) ifTrue:[
			self error: oldClass name, ' cannot be changed'.
		].
		"Check if the receiver should not be redefined"
		(oldClass ~~ nil and:[oldClass shouldNotBeRedefined]) ifTrue:[
			self notify: oldClass name asText allBold, 
						' should not be redefined!! \Proceed to store over it.' withCRs]].

	needNew ifTrue:[
		"Create the new class"
		newClass _ self 
			newSubclassOf: newSuper 
			type: type 
			instanceVariables: instVars
			from: oldClass.
		newClass == nil ifTrue:[^nil]. "Some error"
		newClass setName: className.
	] ifFalse:[
		"Reuse the old class"
		newClass _ oldClass.
	].

	"Install the class variables and pool dictionaries... "
	force _ (newClass declare: classVarString) | (newClass sharing: poolString).

	"... classify ..."
	newCategory _ category asSymbol.
	organization _ Smalltalk organization.
	oldClass isNil ifFalse: [oldCategory := (organization categoryOfElement: oldClass name) asSymbol].
	organization classify: newClass name under: newCategory.

	"... recompile ..."
	newClass _ self recompile: force from: oldClass to: newClass mutate: false.

	"... export if not yet done ..."
	(Smalltalk at: newClass name ifAbsent:[nil]) == newClass ifFalse:[
		[Smalltalk at: newClass name put: newClass]
			on: AttemptToWriteReadOnlyGlobal do:[:ex| ex resume: true].
		Smalltalk flushClassNameCache.
	].

	self doneCompiling: newClass.
	
	"... notify interested clients ..."
	oldClass isNil ifTrue: [
		SystemChangeNotifier uniqueInstance classAdded: newClass inCategory: newCategory.
		^ newClass].
	SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfOldClass to: newClass.
	newCategory ~= oldCategory 
		ifTrue: [SystemChangeNotifier uniqueInstance class: newClass recategorizedFrom: oldCategory to: category].
	^newClass! !


!ClassDescription methodsFor: 'instance variables' stamp: 'jmv 12/7/2009 17:41'!
checkForInstVarsOK: instVarString
	"Return true if instVarString does no include any names used in a subclass"
	| instVarArray |
	instVarArray _ Smalltalk actualScannerClass new scanFieldNames: instVarString.
	self allSubclasses do:
		[:cl | cl instVarNames do:
			[:n | (instVarArray includes: n)
				ifTrue: [self error: n , ' is already used in ' , cl name.
						^ false]]].
	^ true! !


!Class methodsFor: 'initialize-release' stamp: 'jmv 12/7/2009 17:41'!
declare: varString 
	"Declare class variables common to all instances. Answer whether 
	recompilation is advisable."

	| newVars conflicts |
	newVars _ 
		(Smalltalk actualScannerClass new scanFieldNames: varString)
			collect: [:x | x asSymbol].
	newVars do:
		[:var | var first isLowercase
			ifTrue: [self error: var, ' class variable name should be capitalized; proceed to include anyway.']].
	conflicts _ false.
	classPool == nil 
		ifFalse: [(classPool keys reject: [:x | newVars includes: x]) do: 
					[:var | self removeClassVarName: var]].
	(newVars reject: [:var | self classPool includesKey: var])
		do: [:var | "adding"
			"check if new vars defined elsewhere"
			(self bindingOf: var) notNil
				ifTrue: 
					[self error: var , ' is defined elsewhere'.
					conflicts _ true]].
	newVars size > 0
		ifTrue: 
			[classPool _ self classPool.
			"in case it was nil"
			newVars do: [:var | classPool declare: var from: Undeclared]].
	^conflicts! !

!Class methodsFor: 'initialize-release' stamp: 'jmv 12/7/2009 17:41'!
sharing: poolString 
	"Set up sharedPools. Answer whether recompilation is advisable."
	| oldPools found |
	oldPools _ self sharedPools.
	sharedPools _ OrderedCollection new.
	(Smalltalk actualScannerClass new scanFieldNames: poolString) do: 
		[:poolName | 
		sharedPools add: (Smalltalk at: poolName asSymbol ifAbsent:[
			(self confirm: 'The pool dictionary ', poolName,' does not exist.',
						'\Do you want it automatically created?' withCRs)
				ifTrue:[Smalltalk at: poolName asSymbol put: Dictionary new]
				ifFalse:[^self error: poolName,' does not exist']])].
	sharedPools isEmpty ifTrue: [sharedPools _ nil].
	oldPools do: [:pool | found _ false.
				self sharedPools do: [:p | p == pool ifTrue: [found _ true]].
				found ifFalse: [^ true "A pool got deleted"]].
	^ false! !


!CompiledMethod methodsFor: 'printing' stamp: 'jmv 12/7/2009 17:41'!
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"

	| position file preamble stamp tokens tokenCount |
	self fileIndex = 0 ifTrue: [^ String new].  "no source pointer for this method"
	position _ self filePosition.
	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].
	file position: (0 max: position - 150).  "Skip back to before the preamble"
		[file position < (position - 1)]  "then pick it up from the front"
			whileTrue: [preamble _ file nextChunk].
		stamp _ String new.
		tokens _ (preamble findString: 'methodsFor:' startingAt: 1) > 0
			ifTrue: [Smalltalk actualScannerClass 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
! !

!CompiledMethod methodsFor: 'source code management' stamp: 'jmv 12/7/2009 17:25'!
sourceClass
	"Get my receiver class (method class) from the preamble of my source.  Return nil if not found."

	^ [(Smalltalk actualCompilerClass evaluate: (self sourceFileStream backChunk "blank"; backChunk "preamble")) theClass] on: Error do: [nil]! !

!CompiledMethod methodsFor: 'source code management' stamp: 'jmv 12/7/2009 17:25'!
sourceSelector
	"Answer my selector extracted from my source.  If no source answer nil"

	| sourceString |
	sourceString _ self getSourceFromFile ifNil: [^ nil].
	^ Smalltalk actualCompilerClass parserClass new parseSelector: sourceString! !

!CompiledMethod methodsFor: 'decompiling' stamp: 'jmv 12/7/2009 17:53'!
decompilerClass
	^Smalltalk actualDecompilerClass
! !

!CompiledMethod methodsFor: 'decompiling' stamp: 'jmv 12/7/2009 17:35'!
parserClass
	^Smalltalk actualParserClass! !


!DictionaryInspector methodsFor: 'menu' stamp: 'jmv 12/7/2009 17:24'!
addEntry
	| newKey aKey |

	newKey _ FillInTheBlank request:
'Enter new key, then type RETURN.
(Expression will be evaluated for value.)
Examples:  #Fred    ''a string''   3+4'.
	aKey _ Smalltalk actualCompilerClass evaluate: newKey.
	object at: aKey put: nil.
	self calculateKeyArray.
	selectionIndex _ keyArray indexOf: aKey.
	self changed: #inspectObject.
	self changed: #fieldList.
	self update! !

!DictionaryInspector methodsFor: 'menu' stamp: 'jmv 12/7/2009 17:24'!
renameEntry
	| newKey aKey value |

	value _ object at: (keyArray at: selectionIndex).
	newKey _ FillInTheBlank request: 
'Enter new key, then type RETURN.
(Expression will be evaluated for value.)
Examples:  #Fred    ''a string''   3+4'
		 initialAnswer: (keyArray at: selectionIndex) printString.
	aKey _ Smalltalk actualCompilerClass evaluate: newKey.
	object removeKey: (keyArray at: selectionIndex).
	object at: aKey put: value.
	self calculateKeyArray.
	selectionIndex _ keyArray indexOf: aKey.
	self changed: #inspectObject.
	self changed: #fieldList.
	self update! !


!FileContentsBrowser methodsFor: 'edit pane' stamp: 'jmv 12/7/2009 17:24'!
selectedBytecodes
	"Compile the source code for the selected message selector and extract and return
	the bytecode listing."
	| class selector |
	class _ self selectedClassOrMetaClass.
	selector _ self selectedMessageName.
	contents _ class sourceCodeAt: selector.
	contents _ Smalltalk actualCompilerClass new
					parse: contents
					in: class
					notifying: nil.
	contents _ contents generate: #(0 0 0 0).
	^ contents symbolic asText! !

!FileContentsBrowser methodsFor: 'edit pane' stamp: 'jmv 12/7/2009 17:25'!
selectedMessage
	"Answer a copy of the source code for the selected message selector."

	| class selector |
	class _ self selectedClassOrMetaClass.
	selector _ self selectedMessageName.
	contents _ class sourceCodeAt: selector.
	Preferences browseWithPrettyPrint ifTrue: [
		contents _ Smalltalk actualCompilerClass new
					format: contents
					in: class
					notifying: nil].
	self showingAnyKindOfDiffs ifTrue: [
		contents _ self
			methodDiffFor: contents
			class: self selectedClass
			selector: self selectedMessageName
			meta: self metaClassIndicated].
	^ contents asText makeSelectorBoldIn: class! !


!FilePackage methodsFor: 'accessing' stamp: 'jmv 12/7/2009 17:41'!
fixClassOrder
	"Essentially bubble sort the classOrder so that superclasses appear before subclasses"
	| superClass index subClass superIndex |
	index := 0.
	[index < classOrder size] whileTrue:[
		subClass := classOrder at: (index := index + 1).
		superClass := nil.
		subClass isMeta ifTrue:[
			"Treat non-meta as superclass"
			superClass := self classes at: subClass name ifAbsent:[nil].
		] ifFalse:[
			subClass hasDefinition ifTrue:[
				superClass := self classes 
					at: (Smalltalk actualScannerClass new scanTokens: subClass definition) first ifAbsent:[nil].
				superClass ifNotNil:[superClass hasDefinition ifFalse:[superClass := nil]].
			].
		].
		superClass ifNotNil:[
			superIndex := classOrder indexOf: superClass ifAbsent:[self error:'Where is the class?'].
			superIndex > index ifTrue:[
				"Move superClass before index"
				classOrder remove: superClass.
				classOrder add: superClass before: subClass.
				"Rewind index - we need to check superClass itself"
				index := index - 1.
			].
		].
	].
! !

!FilePackage methodsFor: 'private' stamp: 'jmv 12/7/2009 17:41'!
classDefinition: string with: chgRec
	| tokens theClass |
	tokens := Smalltalk actualScannerClass new scanTokens: string.
	tokens size = 11 ifFalse:[^doIts add: chgRec].
	theClass := self getClass: (tokens at: 3).
	theClass definition: string.
	classOrder add: theClass.! !

!FilePackage methodsFor: 'private' stamp: 'jmv 12/7/2009 17:41'!
metaClassDefinition: string with: chgRec
	| tokens theClass |
	tokens := Smalltalk actualScannerClass new scanTokens: string.
	theClass := self getClass: (tokens at: 1).
	theClass metaClass definition: string.
	classOrder add: theClass metaClass.! !

!FilePackage methodsFor: 'private' stamp: 'jmv 12/7/2009 17:41'!
msgClassComment: string with: chgRec
	| tokens theClass |
	tokens := Smalltalk actualScannerClass new scanTokens: string.
	(tokens size = 3 and:[(tokens at: 3) class == String]) ifTrue:[
		theClass := self getClass: tokens first.
		^theClass commentString: tokens last].
	(tokens size = 4 and:[(tokens at: 3) asString = 'class' and:[(tokens at: 4) class == String]]) ifTrue:[
		theClass := self getClass: tokens first.
		theClass metaClass commentString: tokens last].
! !

!FilePackage methodsFor: 'private' stamp: 'jmv 12/7/2009 17:41'!
possibleSystemSource: chgRec
	| tokens |
	sourceSystem isEmpty ifTrue:[
		tokens := Smalltalk actualScannerClass new scanTokens: chgRec string.
		(tokens size = 1 and:[tokens first class == String]) ifTrue:[
			sourceSystem := tokens first.
			^self]].
	doIts add: chgRec.! !

!FilePackage methodsFor: 'private' stamp: 'jmv 12/7/2009 17:41'!
removedMethod: string with: chgRec
	| class tokens |
	tokens := Smalltalk actualScannerClass new scanTokens: string.
	(tokens size = 3 and:[(tokens at: 2) == #removeSelector: ]) ifTrue:[
		class := self getClass: (tokens at: 1).
		^class removeSelector: (tokens at: 3).
	].
	(tokens size = 4 and:[(tokens at: 2) == #class and:[(tokens at: 3) == #removeSelector:]]) ifTrue:[
		class := self getClass: (tokens at: 1).
		^class metaClass removeSelector: (tokens at: 4).
	].
	doIts add: chgRec! !


!ImageSegment methodsFor: 'fileIn/Out' stamp: 'jmv 12/7/2009 17:31'!
scanFrom: aStream
	"Move source code from a fileIn to the changes file for classes in an ImageSegment.  Do not compile the methods.  They already came in via the image segment.  After the ImageSegment in the file, !!ImageSegment new!! captures control, and scanFrom: is called."
	| val chunk |

	[aStream atEnd] whileFalse: 
		[aStream skipSeparators.
		val _ (aStream peekFor: $!!)
			ifTrue: ["Move (aStream nextChunk), find the method or class 
						comment, and install the file location bytes"
					(Smalltalk actualCompilerClass evaluate: aStream nextChunk logged: false)
						scanFromNoCompile: aStream forSegment: self]
			ifFalse: [chunk _ aStream nextChunk.
					aStream checkForPreamble: chunk.
					Smalltalk actualCompilerClass evaluate: chunk logged: true].
		aStream skipStyleChunk].
	"regular fileIn will close the file"
	^ val! !


!InstructionStream methodsFor: 'testing' stamp: 'jmv 12/7/2009 17:55'!
willBlockReturn

	^ (self method at: pc) = Smalltalk actualEncoderClass blockReturnCode! !

!InstructionStream methodsFor: 'testing' stamp: 'jmv 12/7/2009 17:56'!
willJustPop

	^ (self method at: pc) = Smalltalk actualEncoderClass popCode! !


!BlockContext methodsFor: 'printing' stamp: 'jmv 12/7/2009 17:52'!
decompile
	^ Smalltalk actualDecompilerClass new decompileBlock: self! !


!MessageSet methodsFor: 'filtering' stamp: 'jmv 12/7/2009 17:25'!
filterToMessagesThat
	"Allow the user to type in a block which will be"

	| reply |
	reply _ FillInTheBlank
		multiLineRequest: 'Type your block here'
		centerAt: Sensor cursorPoint
		initialAnswer: '[:aClass :aSelector |
	
	]'
		answerHeight: 200.
	reply isEmptyOrNil ifTrue: [^ self].
	self filterFrom: (Smalltalk actualCompilerClass evaluate: reply)
! !


!ChangedMessageSet methodsFor: 'acceptance' stamp: 'jmv 12/7/2009 17:35'!
contents: aString notifying: aController
	"Accept the string as new source for the current method, and make certain the annotation pane gets invalidated"

	| existingSelector existingClass superResult newSelector |
	existingSelector _ self selectedMessageName.
	existingClass _ self selectedClassOrMetaClass.

	superResult _ super contents: aString notifying: aController.
	superResult ifTrue:  "succeeded"
		[newSelector _ Smalltalk actualParserClass new parseSelector: aString.
		newSelector ~= existingSelector
			ifTrue:   "Selector changed -- maybe an addition"
				[self reformulateList.
				self changed: #messageList.
				self messageList doWithIndex:
					[:aMethodReference :anIndex |
						(aMethodReference actualClass == existingClass and:
									[aMethodReference methodSymbol == newSelector])
							ifTrue:
								[self messageListIndex: anIndex]]]].
	^ superResult! !


!MethodHolder methodsFor: 'contents' stamp: 'jmv 12/7/2009 17:35'!
contents: input notifying: aController 
	| selector |
	(selector _ Smalltalk actualParserClass new parseSelector: input asText) ifNil:
		[self inform: 'Sorry - invalid format for the 
method name and arguments -- cannot accept.'.
		^ false].

	selector == methodSelector ifFalse:
		[self inform:
'You cannot change the name of
the method here -- it must continue
to be ', methodSelector.
		^ false].

	selector _ methodClass
				compile: input asText
				classified: self selectedMessageCategoryName
				notifying: aController.
	selector == nil ifTrue: [^ false].
	contents _ input asString copy.
	currentCompiledMethod _ methodClass compiledMethodAt: methodSelector.
	^ true! !


!NonClosureDecompiler methodsFor: 'public access' stamp: 'jmv 12/7/2009 17:53'!
decompile: aSelector in: aClass method: aMethod
	"Answer a MethodNode that is the root of the parse tree for the 
	argument, aMethod, which is the CompiledMethod associated with the 
	message, aSelector. Variables are determined with respect to the 
	argument, aClass."

	^self
		decompile: aSelector
		in: aClass
		method: aMethod
		using: NonClosureDecompilerConstructor new! !

!NonClosureDecompiler methodsFor: 'public access' stamp: 'jmv 12/7/2009 17:53'!
decompileBlock: aBlock 
	"Original version timestamp: sn 1/26/98 18:27
	(Don't know who's sn?) "
	"Decompile aBlock, returning the result as a BlockNode.  
	Show temp names from source if available."
	"Decompiler new decompileBlock: [3 + 4]"
	| startpc end homeClass blockNode tempNames home source |
	(home _ aBlock home) ifNil: [^ nil].
	method _ home method.
	(homeClass _ home who first) == #unknown ifTrue: [^ nil].
	constructor _ NonClosureDecompilerConstructor new.
	method fileIndex ~= 0
		ifTrue: ["got any source code?"
			source _ [method getSourceFromFile]
						on: Error
						do: [:ex | ^ nil].
			tempNames _ ([homeClass compilerClass new
						parse: source
						in: homeClass
						notifying: nil]
						on: (Smalltalk classNamed: 'SyntaxErrorNotification')
						do: [:ex | ^ nil]) tempNames.
			self withTempNames: tempNames].
	self initSymbols: homeClass.
	startpc _ aBlock startpc.
	end _ (method at: startpc - 2)
				\\ 16 - 4 * 256
				+ (method at: startpc - 1) + startpc - 1.
	stack _ OrderedCollection new: method frameSize.
	statements _ OrderedCollection new: 20.
	super method: method pc: startpc - 5.
	blockNode _ self blockTo: end.
	stack isEmpty ifFalse: [self error: 'stack not empty'].
	^ blockNode statements first! !

!NonClosureDecompiler methodsFor: 'private' stamp: 'jmv 12/7/2009 18:07'!
convertToDoLoop
	"If statements contains the pattern
		var _ startExpr.
		[var <= limit] whileTrue: [...statements... var _ var + incConst]
	then replace this by
		startExpr to: limit by: incConst do: [:var | ...statements...]"
	| initStmt toDoStmt limitStmt |
	statements size < 2 ifTrue: [^ self].
	initStmt _ statements at: statements size-1.
	(toDoStmt _ statements last toDoFromWhileWithInit: initStmt)
		== nil ifTrue: [^ self].
	initStmt variable scope: -1.  "Flag arg as block temp"
	statements removeLast; removeLast; addLast: toDoStmt.

	"Attempt further conversion of the pattern
		limitVar _ limitExpr.
		startExpr to: limitVar by: incConst do: [:var | ...statements...]
	to
		startExpr to: limitExpr by: incConst do: [:var | ...statements...]"
	statements size < 2 ifTrue: [^ self].
	limitStmt _ statements at: statements size-1.
	((limitStmt isMemberOf: NonClosureAssignmentNode)
		and: [limitStmt variable isTemp
		and: [limitStmt variable == toDoStmt arguments first
		and: [self methodRefersOnlyOnceToTemp: limitStmt variable fieldOffset]]])
		ifFalse: [^ self].
	toDoStmt arguments at: 1 put: limitStmt value.
	limitStmt variable scope: -2.  "Flag limit var so it won't print"
	statements removeLast; removeLast; addLast: toDoStmt.

! !

!NonClosureDecompiler methodsFor: 'private' stamp: 'jmv 12/7/2009 17:52'!
interpretNextInstructionFor: client

	| code varNames |

"Change false here will trace all state in Transcript."
true ifTrue: [^ super interpretNextInstructionFor: client].

	varNames _ NonClosureDecompiler allInstVarNames.
	code _ (self method at: pc) radix: 16.
	Transcript cr; cr; print: pc; space;
		nextPutAll: '<' , (code copyFrom: 4 to: code size) , '>'.
	8 to: varNames size do:
		[:i | i <= 10 ifTrue: [Transcript cr]
				ifFalse: [Transcript space; space].
		Transcript nextPutAll: (varNames at: i);
				nextPutAll: ': '; print: (self instVarAt: i)].
	Transcript endEntry.
	^ super interpretNextInstructionFor: client! !


!NonClosureParseNode methodsFor: 'converting' stamp: 'jmv 12/7/2009 18:03'!
asReturnNode

	^NonClosureReturnNode new expr: self! !


!NonClosureAssignmentNode methodsFor: 'initialize-release' stamp: 'jmv 12/7/2009 17:57'!
toDoIncrement: var
	var = variable ifFalse: [^ nil].
	(value isMemberOf: NonClosureMessageNode) 
		ifTrue: [^ value toDoIncrement: var]
		ifFalse: [^ nil]! !

!NonClosureAssignmentNode methodsFor: 'initialize-release' stamp: 'jmv 12/7/2009 18:03'!
variable: aVariable value: expression from: encoder

	(aVariable isMemberOf: NonClosureMessageAsTempNode)
		ifTrue: ["Case of remote temp vars"
				^ aVariable store: expression from: encoder].
	variable _ aVariable.
	value _ expression! !


!NonClosureBraceNode methodsFor: 'testing' stamp: 'jmv 12/7/2009 17:49'!
blockAssociationCheck: encoder
	"If all elements are MessageNodes of the form [block]->[block], and there is at
	 least one element, answer true.
	 Otherwise, notify encoder of an error."

	elements size = 0
		ifTrue: [^encoder notify: 'At least one case required'].
	elements with: sourceLocations do:
			[:x :loc |
			(x 	isMessage: #->
				receiver:
					[:rcvr |
					(rcvr isKindOf: NonClosureBlockNode) and: [rcvr numberOfArguments = 0]]
				arguments:
					[:arg |
					(arg isKindOf: NonClosureBlockNode) and: [arg numberOfArguments = 0]])
			  ifFalse:
				[^encoder notify: 'Association between 0-argument blocks required' at: loc]].
	^true! !

!NonClosureBraceNode methodsFor: 'code generation' stamp: 'jmv 12/7/2009 17:58'!
sizeForValue: encoder

	emitNode _ elements size <= 4
		ifTrue: ["Short form: Array braceWith: a with: b ... "
				NonClosureMessageNode new
					receiver: (encoder encodeVariable: #Array)
					selector: (self selectorForShortForm: elements size)
					arguments: elements precedence: 3 from: encoder]
		ifFalse: ["Long form: (Array braceStream: N) nextPut: a; nextPut: b; ...; braceArray"
				NonClosureCascadeNode new
					receiver: (NonClosureMessageNode new
								receiver: (encoder encodeVariable: #Array)
								selector: #braceStream:
								arguments: (Array with: (encoder encodeLiteral: elements size))
								precedence: 3 from: encoder)
					messages: ((elements collect: [:elt | NonClosureMessageNode new receiver: nil
														selector: #nextPut:
														arguments: (Array with: elt)
														precedence: 3 from: encoder])
								copyWith: (NonClosureMessageNode new receiver: nil
														selector: #braceArray
														arguments: (Array new)
														precedence: 1 from: encoder))].
	^ emitNode sizeForValue: encoder! !


!NonClosureDecompilerConstructor methodsFor: 'constructor' stamp: 'jmv 12/7/2009 18:01'!
codeAnyLitInd: association

	^NonClosureVariableNode new
		name: association key
		key: association
		index: 0
		type: LdLitIndType! !

!NonClosureDecompilerConstructor methodsFor: 'constructor' stamp: 'jmv 12/7/2009 17:59'!
codeAnyLiteral: value

	^NonClosureLiteralNode new
		key: value
		index: 0
		type: LdLitType! !

!NonClosureDecompilerConstructor methodsFor: 'constructor' stamp: 'jmv 12/7/2009 18:00'!
codeAnySelector: selector

	^NonClosureSelectorNode new
		key: selector
		index: 0
		type: SendType! !

!NonClosureDecompilerConstructor methodsFor: 'constructor' stamp: 'jmv 12/7/2009 18:07'!
codeAssignTo: variable value: expression

	^NonClosureAssignmentNode new variable: variable value: expression! !

!NonClosureDecompilerConstructor methodsFor: 'constructor' stamp: 'jmv 12/7/2009 17:49'!
codeBlock: statements returns: returns
	^ NonClosureBlockNode statements: statements returns: returns! !

!NonClosureDecompilerConstructor methodsFor: 'constructor' stamp: 'jmv 12/7/2009 17:51'!
codeBrace: elements

	^NonClosureBraceNode new elements: elements! !

!NonClosureDecompilerConstructor methodsFor: 'constructor' stamp: 'jmv 12/7/2009 17:54'!
codeCascade: receiver messages: messages

	^ (NonClosureBraceNode new matchBraceStreamReceiver: receiver messages: messages)
		ifNil: [NonClosureCascadeNode new receiver: receiver messages: messages]! !

!NonClosureDecompilerConstructor methodsFor: 'constructor' stamp: 'jmv 12/7/2009 17:59'!
codeConstants
	"Answer with an array of the objects representing self, true, false, nil,
	-1, 0, 1, 2."

	^(Array with: NodeSelf with: NodeTrue with: NodeFalse with: NodeNil)
		, ((-1 to: 2) collect: [:i | NonClosureLiteralNode new key: i code: LdMinus1 + i + 1])! !

!NonClosureDecompilerConstructor methodsFor: 'constructor' stamp: 'jmv 12/7/2009 17:49'!
codeEmptyBlock

	^NonClosureBlockNode withJust: NodeNil! !

!NonClosureDecompilerConstructor methodsFor: 'constructor' stamp: 'jmv 12/7/2009 18:01'!
codeInst: index

	^NonClosureVariableNode new
		name: (instVars at: index + 1)
		index: index
		type: LdInstType! !

!NonClosureDecompilerConstructor methodsFor: 'constructor' stamp: 'jmv 12/7/2009 17:58'!
codeMessage: receiver selector: selector arguments: arguments
	| symbol node |
	symbol _ selector key.
	(node _ NonClosureBraceNode new
			matchBraceWithReceiver: receiver
			selector: symbol
			arguments: arguments) ifNotNil: [^ node].
	(node _ self decodeIfNilWithReceiver: receiver
			selector: symbol
			arguments: arguments) ifNotNil: [^ node].
	^ NonClosureMessageNode new
			receiver: receiver selector: selector
			arguments: arguments
			precedence: symbol precedence! !

!NonClosureDecompilerConstructor methodsFor: 'constructor' stamp: 'jmv 12/7/2009 17:59'!
codeMethod: selector block: block tempVars: vars primitive: primitive class: class

	| node methodTemps |
	node _ self codeSelector: selector code: nil.
	tempVars _ vars.
	methodTemps _ tempVars select: [:t | t scope >= 0].
	^NonClosureMethodNode new
		selector: node
		arguments: (methodTemps copyFrom: 1 to: nArgs)
		precedence: selector precedence
		temporaries: (methodTemps copyFrom: nArgs + 1 to: methodTemps size)
		block: block
		encoder: (NonClosureEncoder new initScopeAndLiteralTables
					temps: tempVars
					literals: literalValues
					class: class)
		primitive: primitive! !

!NonClosureDecompilerConstructor methodsFor: 'constructor' stamp: 'jmv 12/7/2009 18:00'!
codeSelector: sel code: code

	^NonClosureSelectorNode new key: sel code: code! !

!NonClosureDecompilerConstructor methodsFor: 'constructor' stamp: 'jmv 12/7/2009 18:03'!
codeTemp: index

	^ NonClosureTempVariableNode new
		name: 't' , (index + 1) printString
		index: index
		type: LdTempType
		scope: 0! !

!NonClosureDecompilerConstructor methodsFor: 'constructor' stamp: 'jmv 12/7/2009 18:03'!
codeTemp: index named: tempName

	^ NonClosureTempVariableNode new
		name: tempName
		index: index
		type: LdTempType
		scope: 0! !

!NonClosureDecompilerConstructor methodsFor: 'constructor' stamp: 'jmv 12/7/2009 18:00'!
decodeIfNilWithReceiver: receiver selector: selector arguments: arguments

	selector == #ifTrue:ifFalse:
		ifFalse: [^ nil].
	(receiver isMessage: #==
				receiver: nil
				arguments: [:argNode | argNode == NodeNil])
		ifFalse: [^ nil].
	^ (NonClosureMessageNode new
			receiver: receiver
			selector: (NonClosureSelectorNode new key: #ifTrue:ifFalse: code: #macro)
			arguments: arguments
			precedence: 3)
		noteSpecialSelector: #ifNil:ifNotNil:! !


!NonClosureEncoder methodsFor: 'initialize-release' stamp: 'jmv 12/7/2009 18:03'!
init: aClass context: aContext notifying: req
	| node n homeNode indexNode |
	requestor _ req.
	class _ aClass.
	nTemps _ 0.
	supered _ false.
	self initScopeAndLiteralTables.
	n _ -1.
	class allInstVarNames do: 
		[:variable | 
		node _ NonClosureVariableNode new
					name: variable
					index: (n _ n + 1)
					type: LdInstType.
		scopeTable at: variable put: node].
	aContext == nil
		ifFalse: 
			[homeNode _ self bindTemp: 'homeContext'.
			"first temp = aContext passed as arg"
			n _ 0.
			aContext tempNames do: 
				[:variable | 
				indexNode _ self encodeLiteral: (n _ n + 1).
				node _ NonClosureMessageAsTempNode new
							receiver: homeNode
							selector: #tempAt:
							arguments: (Array with: indexNode)
							precedence: 3
							from: self.
				scopeTable at: variable put: node]].
	sourceRanges _ Dictionary new: 32.
	globalSourceRanges _ OrderedCollection new: 32.
! !

!NonClosureEncoder methodsFor: 'encoding' stamp: 'jmv 12/7/2009 17:59'!
encodeLiteral: object

	^self
		name: object
		key: (class literalScannedAs: object notifying: self)
		class: NonClosureLiteralNode
		type: LdLitType
		set: litSet! !

!NonClosureEncoder methodsFor: 'encoding' stamp: 'jmv 12/7/2009 18:00'!
encodeSelector: selector

	^self
		name: selector
		key: selector
		class: NonClosureSelectorNode
		type: SendType
		set: selectorSet! !

!NonClosureEncoder methodsFor: 'temps' stamp: 'jmv 12/7/2009 18:03'!
newTemp: name

	nTemps _ nTemps + 1.
	^ NonClosureTempVariableNode new
		name: name
		index: nTemps - 1
		type: LdTempType
		scope: 0! !

!NonClosureEncoder methodsFor: 'results' stamp: 'jmv 12/7/2009 18:03'!
tempNames 

	^ self tempNodes collect:
		[:node | (node isMemberOf: NonClosureMessageAsTempNode)
					ifTrue: [scopeTable keyAtValue: node]
					ifFalse: [node key]]! !

!NonClosureEncoder methodsFor: 'private' stamp: 'jmv 12/7/2009 18:02'!
global: ref name: name

	^self
		name: name
		key: ref
		class: NonClosureLiteralVariableNode
		type: LdLitIndType
		set: litIndSet! !


!NonClosureMessageNode methodsFor: 'initialize-release' stamp: 'jmv 12/7/2009 18:00'!
receiver: rcvr selector: aSelector arguments: args precedence: p from: encoder 
	"Compile."

	| theSelector |
	self receiver: rcvr
		arguments: args
		precedence: p.
	aSelector = #:Repeat:do:
		ifTrue: [theSelector _ #do:]
		ifFalse: [theSelector _ aSelector].
	self noteSpecialSelector: theSelector.
	(self transform: encoder)
		ifTrue: 
			[selector isNil
				ifTrue: [selector _ NonClosureSelectorNode new 
							key: (MacroSelectors at: special)
							code: #macro]]
		ifFalse: 
			[selector _ encoder encodeSelector: theSelector.
			rcvr == NodeSuper ifTrue: [encoder noteSuper]].
	self pvtCheckForPvtSelector: encoder! !

!NonClosureMessageNode methodsFor: 'macro transformations' stamp: 'jmv 12/7/2009 18:07'!
toDoFromWhileWithInit: initStmt
	"Return nil, or a to:do: expression equivalent to this whileTrue:"
	| variable increment limit toDoBlock body test |
	(selector key == #whileTrue:
		and: [(initStmt isMemberOf: NonClosureAssignmentNode) and:
				[initStmt variable isTemp]])
		ifFalse: [^ nil].
	body _ arguments last statements.
	variable _ initStmt variable.
	increment _ body last toDoIncrement: variable.
	(increment == nil or: [receiver statements size ~= 1])
		ifTrue: [^ nil].
	test _ receiver statements first.
	"Note: test chould really be checked that <= or >= comparison
	jibes with the sign of the (constant) increment"
	((test isMemberOf: NonClosureMessageNode)
		and: [(limit _ test toDoLimit: variable) notNil])
		ifFalse: [^ nil].
	toDoBlock _ NonClosureBlockNode statements: body allButLast returns: false.
	toDoBlock arguments: (Array with: variable).
	^ NonClosureMessageNode new
		receiver: initStmt value
		selector: (NonClosureSelectorNode new key: #to:by:do: code: #macro)
		arguments: (Array with: limit with: increment with: toDoBlock)
		precedence: precedence! !

!NonClosureMessageNode methodsFor: 'macro transformations' stamp: 'jmv 12/7/2009 17:48'!
transformAnd: encoder
	(self transformBoolean: encoder)
		ifTrue: 
			[arguments _ 
				Array 
					with: (arguments at: 1)
					with: (NonClosureBlockNode withJust: NodeFalse).
			^true]
		ifFalse: 
			[^false]! !

!NonClosureMessageNode methodsFor: 'macro transformations' stamp: 'jmv 12/7/2009 17:48'!
transformIfFalse: encoder
	(self transformBoolean: encoder)
		ifTrue: 
			[arguments _ 
				Array 
					with: (NonClosureBlockNode withJust: NodeNil)
					with: (arguments at: 1).
			^true]
		ifFalse:
			[^false]! !

!NonClosureMessageNode methodsFor: 'macro transformations' stamp: 'jmv 12/7/2009 18:01'!
transformIfNil: encoder

	"vb: Removed the original transformBoolean: which amounds to a test we perform in each of the branches below."
	(MacroSelectors at: special) = #ifNotNil:
	ifTrue:
		[(self checkBlock: arguments first as: 'ifNotNil arg' from: encoder maxArgs: 1) ifFalse: [^ false].
			"Transform 'ifNotNil: [stuff]' to 'ifNil: [nil] ifNotNil: [stuff]'.
			Slightly better code and more consistent with decompilation."
		self noteSpecialSelector: #ifNil:ifNotNil:.
		selector _ NonClosureSelectorNode new key: (MacroSelectors at: special) code: #macro.
		arguments _ {NonClosureBlockNode withJust: NodeNil. arguments first}.
		(self transform: encoder) ifFalse: [self error: 'compiler logic error'].
		^ true]
	ifFalse:
		[^ self checkBlock: arguments first as: 'ifNil arg' from: encoder]
! !

!NonClosureMessageNode methodsFor: 'macro transformations' stamp: 'jmv 12/7/2009 18:07'!
transformIfNilIfNotNil: encoder
	"vb: Changed to support one-argument ifNotNil: branch. In the 1-arg case we transform the receiver to
		(var := receiver)
	which is further transformed to
		(var := receiver) == nil ifTrue: .... ifFalse: ...
	This does not allow the block variable to shadow an existing temp, but it's no different from how to:do: is done."

	| ifNotNilArg blockVar |
	ifNotNilArg := arguments at: 2.
	((self checkBlock: (arguments at: 1) as: 'Nil arg' from: encoder)
		and: [self checkBlock: ifNotNilArg as: 'NotNil arg' from: encoder maxArgs: 1])
			ifFalse: [^false].
	ifNotNilArg numberOfArguments = 1 ifTrue:
		[blockVar := ifNotNilArg firstArgument.
		receiver := NonClosureAssignmentNode new variable: blockVar value: receiver].
	selector _ NonClosureSelectorNode new key: #ifTrue:ifFalse: code: #macro.
	receiver _ NonClosureMessageNode new
		receiver: receiver
		selector: #==
		arguments: (Array with: NodeNil)
		precedence: 2
		from: encoder.
	^true! !

!NonClosureMessageNode methodsFor: 'macro transformations' stamp: 'jmv 12/7/2009 18:07'!
transformIfNotNilIfNil: encoder
	"vb: Changed to support one-argument ifNotNil: branch. In the 1-arg case we transform the receiver to
		(var := receiver)
	which is further transformed to
		(var := receiver) == nil ifTrue: .... ifFalse: ...
	This does not allow the block variable to shadow an existing temp, but it's no different from how to:do: is done."

	| ifNotNilArg blockVar |
	ifNotNilArg := arguments at: 1.
	((self checkBlock: ifNotNilArg as: 'NotNil arg' from: encoder maxArgs: 1)
		and: [self checkBlock: (arguments at: 2) as: 'Nil arg' from: encoder])
			ifFalse: [^false].
		
	ifNotNilArg numberOfArguments = 1 ifTrue:
		[blockVar := ifNotNilArg firstArgument.
		receiver := NonClosureAssignmentNode new variable: blockVar value: receiver].
	selector _ NonClosureSelectorNode new key: #ifTrue:ifFalse: code: #macro.
	receiver _ NonClosureMessageNode new
		receiver: receiver
		selector: #==
		arguments: (Array with: NodeNil)
		precedence: 2
		from: encoder.
	arguments swap: 1 with: 2.
	^true
! !

!NonClosureMessageNode methodsFor: 'macro transformations' stamp: 'jmv 12/7/2009 17:50'!
transformIfTrue: encoder
	(self transformBoolean: encoder)
		ifTrue: 
			[arguments _ 
				Array 
					with: (arguments at: 1)
					with: (NonClosureBlockNode withJust: NodeNil).
			^true]
		ifFalse: 
			[^false]! !

!NonClosureMessageNode methodsFor: 'macro transformations' stamp: 'jmv 12/7/2009 17:48'!
transformOr: encoder
	(self transformBoolean: encoder)
		ifTrue: 
			[arguments _ 
				Array 
					with: (NonClosureBlockNode withJust: NodeTrue)
					with: (arguments at: 1).
			^true]
		ifFalse: 
			[^false]! !

!NonClosureMessageNode methodsFor: 'macro transformations' stamp: 'jmv 12/7/2009 18:08'!
transformToDo: encoder
	" var _ rcvr. L1: [var <= arg1] Bfp(L2) [block body. var _ var + inc] 
Jmp(L1) L2: "
	| limit increment block initStmt test incStmt limitInit blockVar myRange blockRange |
	"First check for valid arguments"
	((arguments last isMemberOf: NonClosureBlockNode)
			and: [arguments last numberOfArguments = 1])
		ifFalse: [^ false].
	arguments last firstArgument isVariableReference
		ifFalse: [^ false]. "As with debugger remote vars"
	arguments size = 3
		ifTrue: [increment _ arguments at: 2.
				(increment isConstantNumber and:
					[increment literalValue ~= 0]) ifFalse: [^ false]]
		ifFalse: [increment _ encoder encodeLiteral: 1].
	arguments size < 3 ifTrue:   "transform to full form"
		[selector _ NonClosureSelectorNode new key: #to:by:do: code: #macro].

	"Now generate auxiliary structures"
	myRange _ encoder rawSourceRanges at: self ifAbsent: [1 to: 0].
	block _ arguments last.
	blockRange _ encoder rawSourceRanges at: block ifAbsent: [1 to: 0].
	blockVar _ block firstArgument.
	initStmt _ NonClosureAssignmentNode new variable: blockVar value: receiver.
	limit _ arguments at: 1.
	limit isVariableReference | limit isConstantNumber
		ifTrue: [limitInit _ nil]
		ifFalse:  "Need to store limit in a var"
			[limit _ encoder autoBind: blockVar key , 'LimiT'.
			limit scope: -2.  "Already done parsing block"
			limitInit _ NonClosureAssignmentNode new
					variable: limit
					value: (arguments at: 1)].
	test _ NonClosureMessageNode new receiver: blockVar
			selector: (increment key > 0 ifTrue: [#<=] ifFalse: [#>=])
			arguments: (Array with: limit)
			precedence: precedence from: encoder
			sourceRange: (myRange first to: blockRange first).
	incStmt _ NonClosureAssignmentNode new
			variable: blockVar
			value: (NonClosureMessageNode new
				receiver: blockVar selector: #+
				arguments: (Array with: increment)
				precedence: precedence from: encoder)
			from: encoder
			sourceRange: (myRange last to: myRange last).
	arguments _ (Array with: limit with: increment with: block)
		, (Array with: initStmt with: test with: incStmt with: limitInit).
	^ true! !

!NonClosureMessageNode methodsFor: 'macro transformations' stamp: 'jmv 12/7/2009 18:01'!
transformWhile: encoder
	(self checkBlock: receiver as: 'receiver' from: encoder)
		ifFalse: [^ false].
	arguments size = 0   "transform bodyless form to body form"
		ifTrue: [selector _ NonClosureSelectorNode new
					key: (special = 10 ifTrue: [#whileTrue:] ifFalse: [#whileFalse:])
					code: #macro.
				arguments _ Array with: (NonClosureBlockNode withJust: NodeNil).
				^ true]
		ifFalse: [^ self transformBoolean: encoder]! !

!NonClosureMessageNode methodsFor: 'printing' stamp: 'jmv 12/7/2009 17:58'!
printKeywords: key arguments: args on: aStream indent: level prefix: isPrefix
	| keywords indent arg kwd doCrTab |
	args size = 0 ifTrue: [
		aStream peekLast isSeparator  ifFalse: [ aStream space ].
		aStream nextPutAll: key. ^ self].
	keywords _ key keywords.
	doCrTab _ args size > 2 or:
		[{receiver} , args
			inject: false
			into: [:was :thisArg |
				was or: [(thisArg isKindOf: NonClosureBlockNode)
					or: [(thisArg isKindOf: NonClosureMessageNode) and: [thisArg precedence >= 3]]]]].
	1 to: (args size min: keywords size) do: [ :i | 
		arg _ args at: i.  kwd _ keywords at: i.
		doCrTab
			ifTrue: [aStream crtab: level+1. indent _ 1] "newline after big args"
			ifFalse: [
				aStream peekLast isSeparator ifFalse: [ aStream space ].
				indent _ 0].
		aStream nextPutAll: kwd; space.
		arg 
			printOn: aStream
			indent: level + 1 + indent
			precedence: (precedence = 2 ifTrue: [1] ifFalse: [precedence]).
	]! !

!NonClosureMessageNode methodsFor: 'printing' stamp: 'jmv 12/7/2009 17:48'!
printParenReceiver: rcvr on: aStream indent: level
					
	(rcvr isKindOf: NonClosureBlockNode) ifTrue:
		[^ rcvr printOn: aStream indent: level].
	aStream nextPutAll: '('.
	rcvr printOn: aStream indent: level.
	aStream nextPutAll: ')'
! !

!NonClosureMessageNode methodsFor: 'printing' stamp: 'jmv 12/7/2009 18:07'!
printToDoOn: aStream indent: level

	| limitNode |
	self printReceiver: receiver on: aStream indent: level.

	(arguments last == nil or: [(arguments last isMemberOf: NonClosureAssignmentNode) not])
		ifTrue: [limitNode _ arguments first]
		ifFalse: [limitNode _ arguments last value].
	(selector key = #to:by:do:
			and: [(arguments at: 2) isConstantNumber
				and: [(arguments at: 2) key = 1]])
		ifTrue: [self printKeywords: #to:do:
					arguments: (Array with: limitNode with: (arguments at: 3))
					on: aStream indent: level prefix: true]
		ifFalse: [self printKeywords: selector key
					arguments: (Array with: limitNode) , arguments allButFirst
					on: aStream indent: level prefix: true]! !

!NonClosureMessageNode methodsFor: 'printing' stamp: 'jmv 12/7/2009 18:00'!
printWhileOn: aStream indent: level

	self printReceiver: receiver on: aStream indent: level.
				(arguments first isJust: NodeNil) ifTrue:
						[selector _ NonClosureSelectorNode new
								key: (selector key == #whileTrue:
									ifTrue: [#whileTrue] ifFalse: [#whileFalse])
								code: #macro.
						arguments _ Array new].
				self printKeywords: selector key arguments: arguments
					on: aStream indent: level! !

!NonClosureMessageNode methodsFor: 'private' stamp: 'jmv 12/7/2009 17:48'!
checkBlock: node as: nodeName from: encoder maxArgs: maxArgs
	"vb: #canBeSpecialArgument for blocks hardcodes 0 arguments as the requirement for special blocks. We work around that here by further checking the number of arguments for blocks.."

	node canBeSpecialArgument ifTrue: 
		[^node isMemberOf: NonClosureBlockNode].
	(node isKindOf: NonClosureBlockNode)
		ifTrue:
			[node numberOfArguments <= maxArgs
				ifTrue: [^true]
				ifFalse: [^encoder notify: '<- ', nodeName , ' of ' ,
					(MacroSelectors at: special) , ' has too many arguments']]
		ifFalse:
			[^encoder notify: '<- ', nodeName , ' of ' ,
					(MacroSelectors at: special) , ' must be a block or variable']! !

!NonClosureMessageNode methodsFor: 'private' stamp: 'jmv 12/7/2009 17:51'!
transformCase: encoder

	| caseNode |
	caseNode _ arguments first.
	(caseNode isKindOf: NonClosureBraceNode)
		ifTrue:
			[^(caseNode blockAssociationCheck: encoder) and:
			 	[arguments size = 1 or:
					[self checkBlock: arguments last as: 'otherwise arg' from: encoder]]].
	(caseNode canBeSpecialArgument and: [(caseNode isMemberOf: NonClosureBlockNode) not])
		ifTrue:
			[^false]. "caseOf: variable"
	^encoder notify: 'caseOf: argument must be a brace construct or a variable'! !

!NonClosureMessageNode methodsFor: 'equation translation' stamp: 'jmv 12/7/2009 18:01'!
eval
	"When everything in me is a constant, I can produce a value.  This is only used by the Scripting system (TilePadMorph tilesFrom:in:)"

	| rec args |
	(receiver isKindOf: NonClosureVariableNode) ifFalse: [^ #illegal].
	rec _ receiver key value.
	args _ arguments collect: [:each | each eval].
	^ rec perform: selector key withArguments: args! !


!NonClosureMessageAsTempNode methodsFor: 'access to remote temps' stamp: 'jmv 12/7/2009 18:03'!
asStorableNode: encoder
	"This node is a message masquerading as a temporary variable.
	It currently has the form {homeContext tempAt: offset}.
	We need to generate code for {expr storeAt: offset inTempFrame: homeContext},
	where the expr, the block argument, is already on the stack.
	This, in turn will get turned into {homeContext tempAt: offset put: expr}
	at runtime if nobody disturbs storeAt:inTempFrame: in Object (not clean)"
	^ NonClosureMessageAsTempNode new
		receiver: nil  "suppress code generation for reciever already on stack"
		selector: #storeAt:inTempFrame:
		arguments: (arguments copyWith: receiver)
		precedence: precedence
		from: encoder! !

!NonClosureMessageAsTempNode methodsFor: 'access to remote temps' stamp: 'jmv 12/7/2009 18:03'!
store: expr from: encoder 
	"ctxt tempAt: n -> ctxt tempAt: n put: expr (see Assignment).
	For assigning into temps of a context being debugged."

	selector key ~= #tempAt: 
		ifTrue: [^self error: 'cant transform this message'].
	^ NonClosureMessageAsTempNode new
		receiver: receiver
		selector: #tempAt:put:
		arguments: (arguments copyWith: expr)
		precedence: precedence
		from: encoder! !


!NonClosureMethodNode methodsFor: 'code generation' stamp: 'jmv 12/7/2009 18:06'!
generate: trailer 
	"The receiver is the root of a parse tree. Answer a CompiledMethod. The
	argument, trailer, is the references to the source code that is stored with 
	every CompiledMethod."

	| blkSize nLits stack strm nArgs method |
	self generate: trailer ifQuick: 
		[:m |  method _ m.
		^ method].
	nArgs _ arguments size.
	blkSize _ block sizeForEvaluatedValue: encoder.
	literals _ encoder allLiterals.
	(nLits _ literals size) > 255
		ifTrue: [^self error: 'Too many literals referenced'].
	method _ CompiledMethod	"Dummy to allocate right size"
				newBytes: blkSize
				trailerBytes: trailer 
				nArgs: nArgs
				nTemps: encoder maxTemp
				nStack: 0
				nLits: nLits
				primitive: primitive.
	strm _ ReadWriteStream with: method.
	strm position: method initialPC - 1.
	stack _ NonClosureParseStack new init.
	block emitForEvaluatedValue: stack on: strm.
	stack position ~= 1 ifTrue: [^self error: 'Compiler stack
discrepancy'].
	strm position ~= (method size - trailer size) 
		ifTrue: [^self error: 'Compiler code size discrepancy'].
	method needsFrameSize: stack size.
	1 to: nLits do: [:lit | method literalAt: lit put: (literals at: lit)].
	^ method! !

!NonClosureMethodNode methodsFor: 'code generation' stamp: 'jmv 12/7/2009 18:06'!
generateNative: trailer 
	"The receiver is the root of a parse tree. Answer a CompiledMethod. The
	argument, trailer, is the references to the source code that is stored with 
	every CompiledMethod."

	| blkSize nLits stack strm nArgs method |
	self generate: trailer ifQuick: 
		[:m |  method _ m.
		^ method].
	nArgs _ arguments size.
	blkSize _ block sizeForEvaluatedValue: encoder.
	literals _ encoder allLiterals.
	(nLits _ literals size) > 255
		ifTrue: [^self error: 'Too many literals referenced'].
	method _ CompiledMethod	"Dummy to allocate right size"
				newBytes: blkSize
				trailerBytes: trailer 
				nArgs: nArgs
				nTemps: encoder maxTemp
				nStack: 0
				nLits: nLits
				primitive: primitive.
	strm _ ReadWriteStream with: method.
	strm position: method initialPC - 1.
	stack _ NonClosureParseStack new init.
	block emitForEvaluatedValue: stack on: strm.
	stack position ~= 1 ifTrue: [^self error: 'Compiler stack
discrepancy'].
	strm position ~= (method size - trailer size) 
		ifTrue: [^self error: 'Compiler code size discrepancy'].
	method needsFrameSize: stack size.
	1 to: nLits do: [:lit | method literalAt: lit put: (literals at: lit)].
	^ method! !

!NonClosureMethodNode methodsFor: 'code generation' stamp: 'jmv 12/7/2009 18:09'!
parserClass
	"Which parser produces this class of parse node"

	^ NonClosureParser! !


!NonClosureParser methodsFor: 'public access' stamp: 'jmv 12/7/2009 18:06'!
parse: sourceStream class: class noPattern: noPattern context: ctxt notifying: req ifFail: aBlock 
	"Answer a MethodNode for the argument, sourceStream, that is the root of 
        a parse tree. Parsing is done with respect to the argument, class, to find 
        instance, class, and pool variables; and with respect to the argument, 
        ctxt, to find temporary variables. Errors in parsing are reported to the 
        argument, req, if not nil; otherwise aBlock is evaluated. The argument 
        noPattern is a Boolean that is true if the the sourceStream does not 
        contain a method header (i.e., for DoIts)."

	| methNode repeatNeeded myStream s p |
	myStream := sourceStream.
	
	[repeatNeeded := false.
	p := myStream position.
	s := myStream upToEnd.
	myStream position: p.
	self 
		init: myStream
		notifying: req
		failBlock: [^aBlock value].
	doitFlag := noPattern.
	failBlock := aBlock.
	
	[methNode := self 
				method: noPattern
				context: ctxt
				encoder: (NonClosureEncoder new 
						init: class
						context: ctxt
						notifying: self)] 
			on: NonClosureParserRemovedUnusedTemps
			do: 
				[:ex | 
				repeatNeeded := (requestor isKindOf: TextEditor) not.
				myStream := ReadStream on: requestor text string.
				ex resume].
	repeatNeeded] 
			whileTrue.
	encoder := failBlock := requestor := parseNode := nil.	"break cycles & mitigate refct overflow"
	methNode sourceText: s.
	^methNode! !

!NonClosureParser methodsFor: 'expression types' stamp: 'jmv 12/7/2009 18:08'!
assignment: varNode
	" var '_' expression => AssignmentNode."
	| loc start |
	(loc _ varNode assignmentCheck: encoder at: prevMark + requestorOffset) >= 0
		ifTrue: [^self notify: 'Cannot store into' at: loc].
	start _ self startOfNextToken.
	varNode nowHasDef.
	self advance.
	self expression ifFalse: [^self expected: 'Expression'].
	parseNode _ NonClosureAssignmentNode new
				variable: varNode
				value: parseNode
				from: encoder
				sourceRange: (start to: self endOfLastToken).
	^true! !

!NonClosureParser methodsFor: 'expression types' stamp: 'jmv 12/7/2009 17:50'!
braceExpression
	" { elements } => BraceNode."

	| elements locations loc more |
	elements _ OrderedCollection new.
	locations _ OrderedCollection new.
	self advance.
	more _ hereType ~~ #rightBrace.
	[more]
		whileTrue: 
			[loc _ hereMark + requestorOffset.
			self expression
				ifTrue: 
					[elements addLast: parseNode.
					locations addLast: loc]
				ifFalse:
					[^self expected: 'Variable or expression'].
			(self match: #period)
				ifTrue: [more _ hereType ~~ #rightBrace]
				ifFalse: [more _ false]].
	parseNode _ NonClosureBraceNode new elements: elements sourceLocations: locations.
	(self match: #rightBrace)
		ifFalse: [^self expected: 'Period or right brace'].
	^true! !

!NonClosureParser methodsFor: 'expression types' stamp: 'jmv 12/7/2009 17:54'!
cascade
	" {; message} => CascadeNode."

	| rcvr msgs |
	parseNode canCascade
		ifFalse: [^self expected: 'Cascading not'].
	rcvr _ parseNode cascadeReceiver.
	msgs _ OrderedCollection with: parseNode.
	[self match: #semicolon]
		whileTrue: 
			[parseNode _ rcvr.
			(self messagePart: 3 repeat: false)
				ifFalse: [^self expected: 'Cascade'].
			parseNode canCascade
				ifFalse: [^self expected: '<- No special messages'].
			parseNode cascadeReceiver.
			msgs addLast: parseNode].
	parseNode _ NonClosureCascadeNode new receiver: rcvr messages: msgs! !

!NonClosureParser methodsFor: 'expression types' stamp: 'jmv 12/7/2009 17:57'!
messagePart: level repeat: repeat

	| start receiver selector args precedence words keywordStart |
	[receiver _ parseNode.
	(hereType == #keyword and: [level >= 3])
		ifTrue: 
			[start _ self startOfNextToken.
			selector _ WriteStream on: (String new: 32).
			args _ OrderedCollection new.
			words _ OrderedCollection new.
			[hereType == #keyword]
				whileTrue: 
					[keywordStart _ self startOfNextToken + requestorOffset.
					selector nextPutAll: self advance.
					words addLast: (keywordStart to: self endOfLastToken + requestorOffset).
					self primaryExpression ifFalse: [^self expected: 'Argument'].
					self messagePart: 2 repeat: true.
					args addLast: parseNode].
			(Symbol hasInterned: selector contents ifTrue: [ :sym | selector _ sym])
				ifFalse: [ selector _ self correctSelector: selector contents
										wordIntervals: words
										exprInterval: (start to: self endOfLastToken)
										ifAbort: [ ^ self fail ] ].
			precedence _ 3]
		ifFalse: [((hereType == #binary or: [hereType == #verticalBar])
				and: [level >= 2])
				ifTrue: 
					[start _ self startOfNextToken.
					selector _ self advance asSymbol.
					self primaryExpression ifFalse: [^self expected: 'Argument'].
					self messagePart: 1 repeat: true.
					args _ Array with: parseNode.
					precedence _ 2]
				ifFalse: [hereType == #word
						ifTrue: 
							[start _ self startOfNextToken.
							selector _ self advance.
							args _ #().
							words _ OrderedCollection with: (start  + requestorOffset to: self endOfLastToken + requestorOffset).
							(Symbol hasInterned: selector ifTrue: [ :sym | selector _ sym])
								ifFalse: [ selector _ self correctSelector: selector
													wordIntervals: words
													exprInterval: (start to: self endOfLastToken)
													ifAbort: [ ^ self fail ] ].
							precedence _ 1]
						ifFalse: [^args notNil]]].
	parseNode _ NonClosureMessageNode new
				receiver: receiver
				selector: selector
				arguments: args
				precedence: precedence
				from: encoder
				sourceRange: (start to: self endOfLastToken).
	repeat]
		whileTrue: [].
	^true! !

!NonClosureParser methodsFor: 'expression types' stamp: 'jmv 12/7/2009 17:59'!
newMethodNode

	^ NonClosureMethodNode new! !

!NonClosureParser methodsFor: 'expression types' stamp: 'jmv 12/7/2009 18:03'!
statements: argNodes innerBlock: inner

	| stmts returns start more blockComment |
	stmts _ OrderedCollection new.
	"give initial comment to block, since others trail statements"
	blockComment _ currentComment.
	currentComment _ nil.
	returns _ false.
	more _ hereType ~~ #rightBracket.
	[more]
		whileTrue: 
		[start _ self startOfNextToken.
		(returns _ self matchReturn)
			ifTrue: 
				[self expression
					ifFalse: [^self expected: 'Expression to return'].
				self addComment.
				stmts addLast: (parseNode isReturningIf
					ifTrue: [parseNode]
					ifFalse: [NonClosureReturnNode new
							expr: parseNode
							encoder: encoder
							sourceRange: (start to: self endOfLastToken)])]
			ifFalse: 
				[self expression
					ifTrue: 
						[self addComment.
						stmts addLast: parseNode]
					ifFalse: 
						[self addComment.
						stmts size = 0
							ifTrue: 
								[stmts addLast: 
									(encoder encodeVariable:
										(inner ifTrue: ['nil'] ifFalse: ['self']))]]].
		returns 
			ifTrue: 
				[self match: #period.
				(hereType == #rightBracket or: [hereType == #doIt])
					ifFalse: [^self expected: 'End of block']].
		more _ returns not and: [self match: #period]].
	parseNode _ NonClosureBlockNode new
				arguments: argNodes
				statements: stmts
				returns: returns
				from: encoder.
	parseNode comment: blockComment.
	^ true! !

!NonClosureParser methodsFor: 'error correction' stamp: 'jmv 12/7/2009 18:02'!
correctVariable: proposedVariable interval: spot
	"Correct the proposedVariable to a known variable, or declare it as a new
	variable if such action is requested.  We support declaring lowercase
	variables as temps or inst-vars, and uppercase variables as Globals or 
	ClassVars, depending on whether the context is nil (class=UndefinedObject).
	Spot is the interval within the test stream of the variable.
	rr 3/4/2004 10:26 : adds the option to define a new class. "

	| tempIvar labels actions lines alternatives binding choice action start end |
	"Check if this is an i-var, that has been corrected already (ugly)"
	(encoder classEncoding instVarNames includes: proposedVariable) ifTrue: [
		^NonClosureLiteralVariableNode new 
			name: proposedVariable index: (encoder classEncoding instVarNames indexOf: proposedVariable) - 1 type: 1;
			yourself ].

	"If we can't ask the user for correction, make it undeclared"
	self interactive 
		ifFalse: [ ^encoder undeclared: proposedVariable ].

	"First check to see if the requestor knows anything about the variable"
	tempIvar _ proposedVariable first isLowercase.
	(tempIvar and: [ (binding _ requestor bindingOf: proposedVariable) notNil ])
		ifTrue: [ ^encoder global: binding name: proposedVariable ].

	"If the requestor is of an exotic kind (like a telnet server) we might not be allowed to open a PupUpMenu for querying the user"
	((requestor isKindOf: Editor) or: [ requestor isMorph ])
		ifFalse: [ ^encoder undeclared: proposedVariable ].

	"Build the menu with alternatives"
	labels _ OrderedCollection new. actions _ OrderedCollection new. lines _ OrderedCollection new.
	alternatives _ encoder possibleVariablesFor: proposedVariable.
	tempIvar 
		ifTrue: [ 
			labels add: 'declare temp'. 
			actions add: [ self declareTempAndPaste: proposedVariable ].
			labels add: 'declare instance'.
			actions add: [ self declareInstVar: proposedVariable ] ]
		ifFalse: [ 
			labels add: 'define new class'.
			actions add: [self defineClass: proposedVariable].
			labels add: 'declare global'.
			actions add: [ self declareGlobal: proposedVariable ].
			encoder classEncoding == UndefinedObject ifFalse: [ 
				labels add: 'declare class variable'.
				actions add: [ self declareClassVar: proposedVariable ] ] ].
	lines add: labels size.
	alternatives do: [ :each | 
		labels add: each.
		actions add: [ 
			self
				substituteWord: each 
				wordInterval: spot 
				offset: 0 
				insideSelection: requestor selectionInterval notEmpty.
			encoder encodeVariable: each ] fixTemps ].
	lines add: labels size.
	labels add: 'cancel'.

	"Display the pop-up menu"
	choice _ (PopUpMenu labelArray: labels asArray lines: lines asArray)
		startUpWithCaption: 'Unknown variable: ', proposedVariable, ' please correct, or cancel:'.
	action _ actions at: choice ifAbsent: [ 
		start _ spot first.
		end _ spot last.
		requestor selectionInterval notEmpty ifTrue: [
			start _ start + requestor startIndex - 1.
			end _ end + requestor startIndex - 1].
		requestor selectFrom: start to: end.
		^self fail ].

	"Execute the selected action"
	^action value! !

!NonClosureParser methodsFor: 'error correction' stamp: 'jmv 12/7/2009 18:02'!
declareInstVar: name
	" rr 3/6/2004 16:06 : adds the line to correctly compute the index. uncommented the option in 
	the caller."
	| index |
	encoder classEncoding addInstVarName: name.
	index _ encoder classEncoding instVarNames indexOf: name.
	encoder classEncoding allSuperclassesDo: [:cls | index := index + cls instVarNames size].
	^NonClosureLiteralVariableNode new
		name: name index: index - 1 type: 1;
		yourself
		! !

!NonClosureParser methodsFor: 'error correction' stamp: 'jmv 12/7/2009 18:08'!
defineClass: className 
	"prompts the user to define a new class,
	asks for it's category, and lets the users edit further
	the definition"
	| sym  cat def d2 |
	sym := className asSymbol.
	cat := FillInTheBlank request: 'Enter class category : ' initialAnswer: 'Unknown'.
	cat ifEmpty: [cat := 'Unknown'].
	def := 'Object subclass: #', sym, '
		instanceVariableNames: '''' 
		classVariableNames: ''''
		poolDictionaries: ''''
		category: ''' , cat, ''''.
	d2 := FillInTheBlank request: 'Edit class definition : ' initialAnswer: def.
	d2 ifEmpty: [d2 := def].
	NonClosureCompiler evaluate: d2.
	^ encoder global: (Smalltalk associationAt: sym) name: sym! !

!NonClosureParser methodsFor: 'error correction' stamp: 'jmv 12/7/2009 18:06'!
removeUnusedTemps
	"Scan for unused temp names, and prompt the user about the prospect of removing each one found"

	| str end start madeChanges | 
	madeChanges _ false.
	str _ requestor text string.
	((tempsMark between: 1 and: str size)
		and: [(str at: tempsMark) = $|]) ifFalse: [^ self].
	encoder unusedTempNames do:
		[:temp |
		((PopUpMenu labels: 'yes\no' withCRs) startUpWithCaption:
			((temp , ' appears to be
unused in this method.
OK to remove it?') asText makeBoldFrom: 1 to: temp size))
			= 1
		ifTrue:
		[(encoder encodeVariable: temp) isUndefTemp
			ifTrue:
			[end _ tempsMark.
			["Beginning at right temp marker..."
			start _ end - temp size + 1.
			end < temp size or: [temp = (str copyFrom: start to: end)
					and: [(str at: start-1) isSeparator & (str at: end+1) isSeparator]]]
			whileFalse:
				["Search left for the unused temp"
				end _ requestor nextTokenFrom: end direction: -1].
			end < temp size ifFalse:
				[(str at: start-1) = $  ifTrue: [start _ start-1].
				requestor correctFrom: start to: end with: ''.
				str _ str copyReplaceFrom: start to: end with: ''. 
				madeChanges _ true.
				tempsMark _ tempsMark - (end-start+1)]]
			ifFalse:
			[self inform:
'You''ll first have to remove the
statement where it''s stored into']]].
	madeChanges ifTrue: [NonClosureParserRemovedUnusedTemps signal]! !


!Object class methodsFor: 'instance creation' stamp: 'jmv 12/7/2009 17:31'!
readCarefullyFrom: textOrString
	"Create an object based on the contents of textOrString.  Return an error instead of putting up a SyntaxError window."

	| object ok |
	ok _ (textOrString isKindOf: Stream) or: [textOrString isKindOf: String].
	(ok or: [textOrString isKindOf: Text]) ifFalse: [^ self error: 'expected String or Text'].
	object _ Smalltalk actualCompilerClass evaluate: textOrString for: nil 
				notifying: #error: "signal we want errors" logged: false.
	(object isKindOf: self) ifFalse: [self error: self name, ' expected'].
	^object! !

!Object class methodsFor: 'instance creation' stamp: 'jmv 12/7/2009 17:31'!
readFrom: aStream
	"Create an object based on the contents of aStream."

	| object ok |
	ok _ (aStream isKindOf: Stream) or: [aStream isKindOf: String].
	(ok or: [aStream isKindOf: Text]) ifFalse: [^ self error: 'expected String or Text'].
	object _ Smalltalk actualCompilerClass evaluate: aStream.
	(object isKindOf: self) ifFalse: [self error: self name, ' expected'].
	^object! !


!NonClosureCompiler class methodsFor: 'accessing' stamp: 'jmv 12/7/2009 18:09'!
old

	^ self new parserClass: NonClosureParser! !

!NonClosureCompiler class methodsFor: 'accessing' stamp: 'jmv 12/7/2009 18:09'!
parserClass
	"Return a parser class to use for parsing method headers."

	^NonClosureParser! !


!NonClosureVariableNode class methodsFor: 'class initialization' stamp: 'jmv 12/7/2009 18:05'!
initialize    "VariableNode initialize.  Decompiler initialize"
	| encoder |
	encoder _ NonClosureEncoder new.
	StdVariables _ Dictionary new: 16.
	encoder
		fillDict: StdVariables
		with: NonClosureVariableNode
		mapping: #('self' 'thisContext' 'super' 'nil' 'false' 'true' )
		to: (Array with: LdSelf with: LdThisContext with: LdSuper)
				, (Array with: LdNil with: LdFalse with: LdTrue).
	StdSelectors _ Dictionary new: 64.
	encoder
		fillDict: StdSelectors
		with: NonClosureSelectorNode
		mapping: ((1 to: Smalltalk specialSelectorSize) collect: 
							[:i | Smalltalk specialSelectorAt: i])
		to: (SendPlus to: SendPlus + 31).
	StdLiterals _ NonClosureLiteralDictionary new: 16.
	encoder
		fillDict: StdLiterals
		with: NonClosureLiteralNode
		mapping: #(-1 0 1 2 )
		to: (LdMinus1 to: LdMinus1 + 3).
	encoder initScopeAndLiteralTables.

	NodeNil _ encoder encodeVariable: 'nil'.
	NodeTrue _ encoder encodeVariable: 'true'.
	NodeFalse _ encoder encodeVariable: 'false'.
	NodeSelf _ encoder encodeVariable: 'self'.
	NodeThisContext _ encoder encodeVariable: 'thisContext'.
	NodeSuper _ encoder encodeVariable: 'super'! !


!OldSimpleClientSocket class methodsFor: 'remote cursor example' stamp: 'jmv 12/7/2009 17:31'!
remoteCursorReceiver
	"Wait for a connection, then display data sent by the client until the client closes the stream. This server process is usually started first (optionally in a forked process), then the sender process is started (optionally on another machine). Note this machine's address, which is printed in the transcript, since the sender process will ask for it."
	"[OldSimpleClientSocket remoteCursorReceiver] fork"

	| sock response ary oldCursor |
	Transcript show: 'starting remote cursor receiver'; cr.
	Transcript show: 'initializing network'; cr.
	Socket initializeNetwork.
	Transcript show: 'my address is ', NetNameResolver localAddressString; cr.
	Transcript show: 'opening connection'; cr.
	sock _ OldSimpleClientSocket new.
	sock listenOn: 54323.
	sock waitForConnectionUntil: (Socket deadlineSecs: 60).
	sock isConnected
		ifFalse: [
			 sock destroy.
			Transcript show: 'remote cursor receiver did not receive a connection in 60 seconds; aborting.'.
			^ self].
	Transcript show: 'connection established'; cr.
	oldCursor _ ActiveHand temporaryCursor.
	ActiveHand showTemporaryCursor: Cursor normal.
	[sock isConnected]
		whileTrue: [
			sock dataAvailable
				ifTrue: [
					response _ sock getResponse.
					ary _ Smalltalk actualCompilerClass evaluate: response.
					Sensor processEvent: ary.
					ActiveHand temporaryCursor isNil ifTrue: [
						ActiveHand showTemporaryCursor: Cursor normal]
					]
				ifFalse: [
					"if no data available, let other processes run for a while"
					(Delay forMilliseconds: 60) wait]].

	sock destroy.
	Transcript show: 'remote cursor receiver done'; cr.
	ActiveHand showTemporaryCursor: oldCursor
! !


!PolygonMorph methodsFor: 'menu' stamp: 'jmv 12/7/2009 17:32'!
specifyDashedLine

	| executableSpec newSpec |
	executableSpec _ FillInTheBlank
		request:
'Enter a dash specification as
{ major dash length. minor dash length. minor dash color }
The major dash will have the normal border color.
A blank response will remove the dash specification.
[Note: You may give 5 items as, eg, {10. 5. Color white. 0. 3}
where the 4th ityem is zero, and the 5th is the number of pixels
by which the dashes will move in each step of animation]'
		initialAnswer: '{ 10. 5. Color red }'.
	executableSpec isEmpty ifTrue:
		[^ self stopStepping; dashedBorder: nil].
	newSpec _ [Smalltalk actualCompilerClass evaluate: executableSpec] ifError:
		[^ self stopStepping; dashedBorder: nil].
	newSpec first isNumber & newSpec second isNumber & newSpec third isColor ifFalse:
		[^ self stopStepping; dashedBorder: nil].
	newSpec size = 3 ifTrue:
		[^ self stopStepping; dashedBorder: newSpec].
	(newSpec size = 5 and: [newSpec fourth isNumber & newSpec fifth isNumber]) ifTrue:
		[^ self dashedBorder: newSpec; startStepping].
! !


!PositionableStream methodsFor: 'fileIn/Out' stamp: 'jmv 12/7/2009 17:25'!
copyPreamble: preamble from: aStream
	"Look for a changeStamp for this method by peeking backward.
	Write a method preamble, with that stamp if found."
	| terminator methodPos oldPreamble stamp oldClassName |
	terminator _ $!!.

	"Look back to find stamp in old preamble, such as...
	Polygon methodsFor: 'private' stamp: 'di 6/25/97 21:42' prior: 34957598!! "
	methodPos _ aStream position.
	aStream backChunk.				"to beginning of method"
	oldPreamble _ aStream backChunk.		"to get preamble"
	aStream position: methodPos.
	oldClassName _ oldPreamble substrings first asSymbol.
	(Smalltalk includesKey: oldClassName) ifFalse: [
		oldPreamble _ 'Object', (oldPreamble copyFrom: oldClassName size+1 to: oldPreamble size) ].
	stamp _ (Smalltalk actualCompilerClass evaluate: oldPreamble) changeStamp ifNil: [''].
	"Write the new preamble, with old stamp if any."
	self cr; nextPut: terminator.
	self nextChunkPut: (String streamContents: [ :strm |
		strm nextPutAll: preamble.
		stamp size > 0 ifTrue: [
			strm nextPutAll: ' stamp: '; print: stamp]]).
	self cr! !

!PositionableStream methodsFor: 'fileIn/Out' stamp: 'jmv 12/7/2009 17:25'!
fileInAnnouncing: announcement 
	"This is special for reading expressions from text that has been formatted 
	with exclamation delimitors. The expressions are read and passed to the 
	Compiler. Answer the result of compilation.  Put up a progress report with
     the given announcement as the title."

	| val chunk |
	announcement 
		displayProgressAt: Sensor cursorPoint
		from: 0
		to: self size
		during: 
			[:bar | 
			[self atEnd] whileFalse: 
					[bar value: self position.
					self skipSeparators.
					
					[val := (self peekFor: $!!) 
								ifTrue: [
									chunk := self nextChunk.
									(chunk beginsWith: 'classDefinition: ')
										ifFalse: [(Smalltalk actualCompilerClass evaluate: chunk logged: false) scanFrom: self]]
								ifFalse: [
									chunk := self nextChunk.
									self checkForPreamble: chunk.
									Smalltalk actualCompilerClass evaluate: chunk logged: true]] 
							on: InMidstOfFileinNotification
							do: [:ex | ex resume: true].
					self skipStyleChunk].
			self close].
	"Note:  The main purpose of this banner is to flush the changes file."
	Smalltalk logChange: '----End fileIn of ' , self name , '----'.
	self flag: #ThisMethodShouldNotBeThere.	"sd"
	Smalltalk forgetDoIts.
	^val! !


!PseudoClass methodsFor: 'accessing' stamp: 'jmv 12/7/2009 17:23'!
compilerClass
	^ (Smalltalk at: name ifAbsent: [^ Smalltalk actualCompilerClass]) compilerClass! !

!PseudoClass methodsFor: 'private' stamp: 'jmv 12/7/2009 17:23'!
evaluate: aString
	^Smalltalk actualCompilerClass evaluate: aString for: nil logged: true! !

!PseudoClass methodsFor: 'private' stamp: 'jmv 12/7/2009 17:23'!
parserClass

	^ Smalltalk actualCompilerClass parserClass! !


!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'jmv 12/7/2009 17:41'!
markMatchingClasses
	"If an example is used, mark classes matching the example instance with an asterisk."

	| unmarkedClassList firstPartOfSelector receiverString receiver |

	self flag: #mref.	"allows for old-fashioned style"

	"Only 'example' queries can be marked."
	(contents asString includes: $.) ifFalse: [^ self].

	unmarkedClassList _ classList copy.

	"Get the receiver object of the selected statement in the message list."
	firstPartOfSelector _ (Smalltalk actualScannerClass new scanTokens: (selectorList at: selectorIndex)) second.
	receiverString _ (ReadStream on: (selectorList at: selectorIndex))
						upToAll: firstPartOfSelector.
	receiver _ Smalltalk actualCompilerClass evaluate: receiverString.

	unmarkedClassList do: [ :classAndMethod | | class |
		(classAndMethod isKindOf: MethodReference) ifTrue: [
			(receiver isKindOf: classAndMethod actualClass) ifTrue: [
				classAndMethod stringVersion: '*', classAndMethod stringVersion..
			]
		] ifFalse: [
			class _ Smalltalk actualCompilerClass evaluate:
					((ReadStream on: classAndMethod) upToAll: firstPartOfSelector).
			(receiver isKindOf: class) ifTrue: [
				classList add: '*', classAndMethod.
				classList remove: classAndMethod
			]
		].
	].
! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'jmv 12/7/2009 17:57'!
quickList
	"Compute the selectors for the single example of receiver and args, in the very top pane" 

	| data result resultArray newExp dataStrings mf dataObjects aa |
	data _ contents asString.
	"delete trailing period. This should be fixed in the Parser!!"
 	[data last isSeparator] whileTrue: [data _ data allButLast]. 
	data last = $. ifTrue: [data _ data allButLast]. 	"Eval"
	mf _ MethodFinder new.
	data _ mf cleanInputs: data.	"remove common mistakes"
	dataObjects _ Smalltalk actualCompilerClass evaluate: '{', data, '}'. "#( data1 data2 result )"
 	dataStrings _ (Smalltalk actualCompilerClass new parse: 'zort ' , data in: Object notifying: nil)
				block statements allButLast collect:
				[:node | String streamContents:
					[:strm | (node isKindOf: Smalltalk actualMessageNodeClass) ifTrue: [strm nextPut: $(].
					node printOn: strm indent: 0.
					(node isKindOf: Smalltalk actualMessageNodeClass) ifTrue: [strm nextPut: $)].]].
	dataObjects size < 2 ifTrue: [self inform: 'If you are giving an example of receiver, \args, and result, please put periods between the parts.\Otherwise just type one selector fragment' withCRs. ^#()].
 	dataObjects _ Array with: dataObjects allButLast with: dataObjects last. "#( (data1 data2) result )" 
	result _ mf load: dataObjects; findMessage.
	(result first beginsWith: 'no single method') ifFalse: [
		aa _ self testObjects: dataObjects strings: dataStrings.
		dataObjects _ aa second.  dataStrings _ aa third].
	resultArray _ self listFromResult: result. 
	resultArray isEmpty ifTrue: [self inform: result first].

	dataStrings size = (dataObjects first size + 1) ifTrue:
		[resultArray _ resultArray collect: [:expression |
		newExp _ expression.
		dataObjects first withIndexDo: [:lit :i |
			newExp _ newExp copyReplaceAll: 'data', i printString
							with: (dataStrings at: i)].
		newExp, ' --> ', dataStrings last]].

 	^ resultArray! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'jmv 12/7/2009 17:42'!
selectedMessageName
	"Answer the name of the currently selected message."

	| example tokens |
	selectorIndex = 0 ifTrue: [^nil].
	example _ selectorList at: selectorIndex.
	tokens _ Smalltalk actualScannerClass new scanTokens: example.
	tokens size = 1 ifTrue: [^ tokens first].
	tokens first == #'^' ifTrue: [^ nil].
	(tokens second includes: $:) ifTrue: [^ example findSelector].
	Symbol hasInterned: tokens second ifTrue: [:aSymbol | ^ aSymbol].
	^ nil! !


!SimpleButtonMorph methodsFor: 'menu' stamp: 'jmv 12/7/2009 17:32'!
setArguments

	| s newArgs newArgsArray |
	s _ WriteStream on: ''.
	arguments do: [:arg | arg printOn: s. s nextPutAll: '. '].
	newArgs _ FillInTheBlank
		request:
'Please type the arguments to be sent to the target
when this button is pressed separated by periods'
		initialAnswer: s contents.
	newArgs isEmpty ifFalse: [
		newArgsArray _ Smalltalk actualCompilerClass evaluate: '{', newArgs, '}' for: self logged: false.
		self arguments: newArgsArray].
! !


!SmalltalkEditor methodsFor: 'do-its' stamp: 'jmv 12/7/2009 17:32'!
compileSelectionFor: anObject in: evalContext

	| methodNode method |
	methodNode _ [Smalltalk actualCompilerClass new
		compileNoPattern: self selectionAsStream
		in: anObject class
		context: evalContext
		notifying: self
		ifFail: [^nil]]
			on: OutOfScopeNotification
			do: [:ex | ex resume: true].
	method _ methodNode generate: #(0 0 0 0).
	^method copyWithTempNames: methodNode tempNames! !


!Symbol methodsFor: 'printing' stamp: 'jmv 12/7/2009 17:42'!
storeOn: aStream 

	aStream nextPut: $#.
	(Smalltalk actualScannerClass isLiteralSymbol: self)
		ifTrue: [aStream nextPutAll: self]
		ifFalse: [super storeOn: aStream]! !


!Symbol class methodsFor: 'instance creation' stamp: 'jmv 12/7/2009 17:42'!
readFrom: strm  "Symbol readFromString: '#abc'"

	strm peek = $# ifFalse: [self error: 'Symbols must be introduced by #'].
	^ (Smalltalk actualScannerClass new scan: strm) advance  "Just do what the code scanner does"! !


!SyntaxError methodsFor: 'initialization' stamp: 'jmv 12/7/2009 17:42'!
setClass: aClass code: aString debugger: aDebugger doitFlag: flag

	| types printables badChar |
	class _ aClass.
	debugger _ aDebugger.
	selector _ aClass parserClass new parseSelector: aString.
	types _ Smalltalk actualScannerClass classPool at: #TypeTable.	"dictionary"
	printables _ '!!@#$%&*-_=+<>{}?/\,¥£¢¤¦»¼ÐÑÒÔÓÕÉò¾òøùÀÇÈ`~`' asSet.
	badChar _ aString detect: [:aChar | (types at: aChar asciiValue) == #xBinary and: [
			(printables includes: aChar) not]] ifNone: [nil].
	contents _ badChar 
		ifNil: [aString]
		ifNotNil: ['<<<This string contains a character (ascii value ', 
			badChar asciiValue printString,
			') that is not normally used in code>>> ', aString].
	category ifNil: [category _ aClass organization categoryOfElement: selector].
	category ifNil: [category _ ClassOrganizer default].
	doitFlag _ flag! !

!SyntaxError methodsFor: 'other' stamp: 'jmv 12/7/2009 17:23'!
contents: aString notifying: aController
	"Compile the code in aString and notify aController of any errors. If there are no errors, then automatically proceed."

	doitFlag
	ifTrue: [Smalltalk actualCompilerClass new evaluate: aString in: nil to: nil
						notifying: aController ifFail: [^ false]]
	ifFalse: [(class compile: aString classified: category
						notifying: aController) ifNil: [^ false]].

	aController hasUnacceptedEdits: false.
	self proceed! !


!Text methodsFor: 'emphasis' stamp: 'jmv 12/7/2009 17:25'!
makeSelectorBold
	"For formatting Smalltalk source code, set the emphasis of that portion of 
	the receiver's string that parses as a message selector to be bold."

	| parser i |
	string size = 0 ifTrue: [^ self].
	i _ 0.
	[(string at: (i _ i + 1)) isSeparator] whileTrue.
	(string at: i) = $[ ifTrue: [^ self].  "block, no selector"
	(parser _ Smalltalk actualCompilerClass parserClass new) parseSelector: string.
	self makeBoldFrom: 1 to: (parser endOfLastToken min: string size)! !


!TextDoIt methodsFor: 'as yet unclassified' stamp: 'jmv 12/7/2009 17:25'!
actOnClickFor: anObject
	"Note: evalString gets evaluated IN THE CONTEXT OF anObject
	 -- meaning that self and all instVars are accessible"
	Smalltalk actualCompilerClass evaluate: evalString for: anObject logged: false.
	^ true ! !


!TextPrintIt methodsFor: 'as yet unclassified' stamp: 'jmv 12/7/2009 17:25'!
actOnClickFor: anObject in: aParagraph at: clickPoint editor: editor
	"Note: evalString gets evaluated IN THE CONTEXT OF anObject
	 -- meaning that self and all instVars are accessible"
	| result range index |
	result _ Smalltalk actualCompilerClass evaluate: evalString for: anObject logged: false.
	result _ ' ', result printString,' '.
	"figure out where the attribute ends in aParagraph"
	index _ (aParagraph characterBlockAtPoint: clickPoint) stringIndex.
	range _ aParagraph text rangeOf: self startingAt: index.
	editor selectFrom: range last+1 to: range last.
	editor zapSelectionWith: result.
	editor selectFrom: range last to: range last + result size.
	^ true ! !


!Transcripter methodsFor: 'command line' stamp: 'jmv 12/7/2009 17:25'!
readEvalPrint
	| line okToRevert |
	okToRevert _ true.
	[#('quit' 'exit' 'done' ) includes: (line _ self request: '>')]
		whileFalse:
		[line = 'revert'
		ifTrue: [okToRevert
			ifTrue: [Utilities revertLastMethodSubmission.
					self cr; show: 'reverted: ' , Utilities mostRecentlySubmittedMessage.
					okToRevert _ false]
			ifFalse: [self cr; show: 'Only one level of revert currently supported']]
		ifFalse: [self cr; show: ([Smalltalk actualCompilerClass evaluate: line] ifError: [:err :ex | err])]]! !


!UndefinedObject methodsFor: 'class hierarchy' stamp: 'jmv 12/7/2009 17:23'!
subclassDefinerClass
	"For disjunct class hierarchies -- how should subclasses of nil be evaluated"
	^Smalltalk actualCompilerClass! !


!Utilities class methodsFor: 'common requests' stamp: 'jmv 12/7/2009 17:31'!
eval: aString
	"Evaluate the string in a neutral context, and under certain circumstances print the 
	result in the transcript"

	| result |
	result _ Smalltalk actualCompilerClass new evaluate: aString in: nil to: nil.
	(result isKindOf: Number) | (result isKindOf: String)
		ifTrue:
			[Transcript cr; nextPutAll: result printString]! !

!Utilities class methodsFor: 'common requests' stamp: 'jmv 12/7/2009 17:31'!
evaluate: aString in: aContext to: aReceiver
	"evaluate aString in the given context, and return the result.  2/2/96 sw"
	
	self deprecated: 'Use Compiler>>evaluate: aString in: aContext to: aReceiver'.
	^ Smalltalk actualCompilerClass new evaluate: aString in: aContext to: aReceiver! !

!Utilities class methodsFor: 'summer97 additions' stamp: 'jmv 12/7/2009 17:42'!
isLegalInstVarName: aString
	"Answer whether aString is a legal instance variable name."

	^ ((Smalltalk actualScannerClass isLiteralSymbol: aString) and: [(aString includes: $:) not]) and:
		[(self inviolateInstanceVariableNames includes:  aString) not]! !


!VersionsBrowser methodsFor: 'init & update' stamp: 'jmv 12/7/2009 17:42'!
scanVersionsOf: method class: class meta: meta category: category selector: selector
	| position prevPos prevFileIndex preamble tokens sourceFilesCopy stamp |
	selectorOfMethod _ selector.
	currentCompiledMethod _ method.
	classOfMethod _ meta ifTrue: [class class] ifFalse: [class].
	changeList _ OrderedCollection new.
	list _ OrderedCollection new.
	self addedChangeRecord ifNotNil: [ :change |
		self addItem: change text: ('{1} (in {2})' translated format: { change stamp. change fileName }) ].
	listIndex _ 0.
	position _ method filePosition.
	sourceFilesCopy _ SourceFiles collect:
		[:x | x isNil ifTrue: [ nil ]
				ifFalse: [x readOnlyCopy]].
	method fileIndex = 0 ifTrue: [^ nil].
	file _ sourceFilesCopy at: method fileIndex.
	[position notNil & file notNil]
		whileTrue:
		[file position: (0 max: position-150).  "Skip back to before the preamble"
		[file position < (position-1)]  "then pick it up from the front"
			whileTrue: [preamble _ file nextChunk].

		"Preamble is likely a linked method preamble, if we're in
			a changes file (not the sources file).  Try to parse it
			for prior source position and file index"
		prevPos _ nil.
		stamp _ ''.
		(preamble findString: 'methodsFor:' startingAt: 1) > 0
			ifTrue: [tokens _ Smalltalk actualScannerClass new scanTokens: preamble]
			ifFalse: [tokens _ Array new  "ie cant be back ref"].
		((tokens size between: 7 and: 8)
			and: [(tokens at: tokens size-5) = #methodsFor:])
			ifTrue:
				[(tokens at: tokens size-3) = #stamp:
				ifTrue: ["New format gives change stamp and unified prior pointer"
						stamp _ tokens at: tokens size-2.
						prevPos _ tokens last.
						prevFileIndex _ sourceFilesCopy fileIndexFromSourcePointer: prevPos.
						prevPos _ sourceFilesCopy filePositionFromSourcePointer: prevPos]
				ifFalse: ["Old format gives no stamp; prior pointer in two parts"
						prevPos _ tokens at: tokens size-2.
						prevFileIndex _ tokens last].
				(prevPos = 0 or: [prevFileIndex = 0]) ifTrue: [prevPos _ nil]].
		((tokens size between: 5 and: 6)
			and: [(tokens at: tokens size-3) = #methodsFor:])
			ifTrue:
				[(tokens at: tokens size-1) = #stamp:
				ifTrue: ["New format gives change stamp and unified prior pointer"
						stamp _ tokens at: tokens size]].
 		self addItem:
				(ChangeRecord new file: file position: position type: #method
						class: class name category: category meta: meta stamp: stamp)
			text: stamp , ' ' , class name , (meta ifTrue: [' class '] ifFalse: [' ']) , selector.
		position _ prevPos.
		prevPos notNil ifTrue:
			[file _ sourceFilesCopy at: prevFileIndex]].
	sourceFilesCopy do: [:x | x notNil ifTrue: [x close]].
	listSelections _ Array new: list size withAll: false! !


!ClassCommentVersionsBrowser methodsFor: 'basic function' stamp: 'jmv 12/7/2009 17:41'!
scanVersionsOf: class 
	"Scan for all past versions of the class comment of the given class"

	| oldCommentRemoteStr sourceFilesCopy position prevPos stamp preamble tokens prevFileIndex |

	classOfMethod _ class.
	oldCommentRemoteStr _ class  organization commentRemoteStr.
	currentCompiledMethod _ oldCommentRemoteStr.
	selectorOfMethod _ #Comment.
	changeList _ OrderedCollection new.
	list _ OrderedCollection new.
	listIndex _ 0.
	oldCommentRemoteStr ifNil:[^ nil] ifNotNil: [oldCommentRemoteStr sourcePointer].

	sourceFilesCopy _ SourceFiles collect:
		[:x | x isNil ifTrue: [ nil ]
				ifFalse: [x readOnlyCopy]].
	position _ oldCommentRemoteStr position.
	file _ sourceFilesCopy at: oldCommentRemoteStr sourceFileNumber.
	[position notNil & file notNil]
		whileTrue:
		[file position: (0 max: position-150).  " Skip back to before the preamble"
		[file position < (position-1)]  "then pick it up from the front"
			whileTrue: [preamble _ file nextChunk].

		prevPos _ nil.
		stamp _ ''.
		(preamble findString: 'commentStamp:' startingAt: 1) > 0
			ifTrue: [tokens _ Smalltalk actualScannerClass new scanTokens: preamble.
				(tokens at: tokens size-3) = #commentStamp:
				ifTrue: ["New format gives change stamp and unified prior pointer"
						stamp _ tokens at: tokens size-2.
						prevPos _ tokens last.
						prevFileIndex _ sourceFilesCopy fileIndexFromSourcePointer: prevPos.
						prevPos _ sourceFilesCopy filePositionFromSourcePointer: prevPos]]
			ifFalse: ["The stamp get lost, maybe after a condenseChanges"
					stamp _ '<historical>'].
 		self addItem:
				(ChangeRecord new file: file position: position type: #classComment
						class: class name category: nil meta: class stamp: stamp)
			text: stamp , ' ' , class name , ' class comment'. 
		prevPos = 0 ifTrue:[prevPos _ nil].
		position _ prevPos.
		prevPos notNil 
					ifTrue:[file _ sourceFilesCopy at: prevFileIndex]].
	sourceFilesCopy do: [:x | x notNil ifTrue: [x close]].
	listSelections _ Array new: list size withAll: false! !

NonClosureVariableNode initialize!
