[pypy-commit] lang-smalltalk stmgc-c7: Broken Verion. Adds basic multi-threading through the rthred module. RThread module added, bootstrapper added to pass arguments to the thread, added ProcessWrapper to wrap squeak process objects and added stm_fork primitive

Patrick Rein noreply at buildbot.pypy.org
Thu May 15 18:25:05 CEST 2014


Author: Patrick Rein <patrick.rein at student.hpi.uni-potsdam.de>
Branch: stmgc-c7
Changeset: r832:39243de49282
Date: 2014-05-15 18:18 +0200
http://bitbucket.org/pypy/lang-smalltalk/changeset/39243de49282/

Log:	Broken Verion. Adds basic multi-threading through the rthred module.
	RThread module added, bootstrapper added to pass arguments to the
	thread, added ProcessWrapper to wrap squeak process objects and
	added stm_fork primitive

diff too long, truncating to 2000 out of 306526 lines

diff --git a/images/Squeak4.5-12568.changes b/images/Squeak4.5-12568.changes
--- a/images/Squeak4.5-12568.changes
+++ b/images/Squeak4.5-12568.changes
@@ -36,4 +36,4 @@
 Workspace allInstances do: [:w | w topView delete].
 ReleaseBuilderFor4dot4 prepareNewBuild.
 Smalltalk snapshot: true andQuit: true.
-!

----End fileIn of a stream----!

----SNAPSHOT----{31 March 2013 . 3:27:34 pm} Squeak4.5-12327.image priorSource: 7430688!
!Installer methodsFor: 'squeakmap' stamp: 'fbs 1/28/2013 19:25' prior: 57597950!
packageAndVersionFrom: pkg
	| p |
	p := ReadStream on: pkg .
	^{(p upTo: $(). p upTo: $)} collect: [:s | s withBlanksTrimmed].! !

"Installer-Core"!
!Categorizer methodsFor: 'fileIn/Out' stamp: 'cwp 6/20/2012 16:58'!
scanFrom: aStream environment: anEnvironment
	^ self scanFrom: aStream! !
!ClassCategoryReader methodsFor: 'fileIn/Out' stamp: 'cwp 6/20/2012 17:21'!
scanFrom: aStream environment: anEnvironment
	"File in methods from the stream, aStream."
	| methodText |
	[methodText := aStream nextChunkText.
	 methodText size > 0] whileTrue:
		[class 
			compile: methodText 
			environment: anEnvironment
			classified: category
			withStamp: changeStamp 
			notifying: nil]! !
!ClassCommentReader methodsFor: 'as yet unclassified' stamp: 'cwp 6/20/2012 17:22'!
scanFrom: aStream environment: anEnvironment
	^ self scanFrom: aStream! !
!Metaclass methodsFor: 'compiling' stamp: 'cwp 6/20/2012 17:29'!
bindingOf: varName environment: anEnvironment 
	^ thisClass classBindingOf: varName environment: anEnvironment! !
!LargePositiveInteger methodsFor: 'arithmetic' stamp: 'nice 12/30/2012 20:03' prior: 22505876!
\\ aNumber 
	"Primitive. Take the receiver modulo the argument. The result is the
	remainder rounded towards negative infinity, of the receiver divided
	by the argument. Fail if the argument is 0. Fail if either the argument
	or the result is not a SmallInteger or a LargePositiveInteger less than
	2-to-the-30th (1073741824). Optional. See Object documentation whatIsAPrimitive."

	<primitive: 31>
	aNumber isInteger
		ifTrue:
			[| neg qr q r |
			neg := self negative == aNumber negative == false.
			qr := (self digitDiv:
				(aNumber class == SmallInteger
					ifTrue: [aNumber abs]
					ifFalse: [aNumber])
				neg: neg).
			q := qr first normalize.
			r := qr last normalize.
			^(q negative
				ifTrue: [r isZero not]
				ifFalse: [q isZero and: [neg]])
					ifTrue: [r + aNumber]
					ifFalse: [r]].
	^super \\ aNumber
	! !
!LargePositiveInteger methodsFor: 'converting' stamp: 'nice 1/27/2012 22:41' prior: 37616324!
asFloat
	"Answer a Float that best approximates the value of the receiver.
	This algorithm is optimized to process only the significant digits of a LargeInteger.
	And it does honour IEEE 754 round to nearest even mode in case of excess precision (see details below)."
	
	"How numbers are rounded in IEEE 754 default rounding mode:
	A shift is applied so that the highest 53 bits are placed before the floating point to form a mantissa.
	The trailing bits form the fraction part placed after the floating point.
	This fractional number must be rounded to the nearest integer.
	If fraction part is 2r0.1, exactly between two consecutive integers, there is a tie.
	The nearest even integer is chosen in this case.
	Examples (First 52bits of mantissa are omitted for brevity):
	2r0.00001 is rounded downward to 2r0
	2r1.00001 is rounded downward to 2r1
	2r0.1 is a tie and rounded to 2r0 (nearest even)
	2r1.1 is a tie and rounded to 2r10 (nearest even)
	2r0.10001 is rounded upward to 2r1
	2r1.10001 is rounded upward to 2r10
	Thus, if the next bit after floating point is 0, the mantissa is left unchanged.
	If next bit after floating point is 1, an odd mantissa is always rounded upper.
	An even mantissa is rounded upper only if the fraction part is not a tie."
	
	"Algorihm details:
	The floating point hardware can perform the rounding correctly with several excess bits as long as there is a single inexact operation.
	This can be obtained by splitting the mantissa plus excess bits in two part with less bits than Float precision.
	Note 1: the inexact flag in floating point hardware must not be trusted because in some cases the operations would be exact but would not take into account some bits that were truncated before the Floating point operations.
	Note 2: the floating point hardware is presumed configured in default rounding mode."
	
	| mantissa shift excess result n |

	"Check how many bits excess the maximum precision of a Float mantissa."
	excess := self highBitOfMagnitude - Float precision.
	excess > 7
		ifTrue:
			["Remove the excess bits but seven."
			mantissa := self bitShiftMagnitude: 7 - excess.
			shift := excess - 7.
			"An even mantissa with a single excess bit immediately following would be truncated.
			But this would not be correct if above shift has truncated some extra bits.
			Check this case, and round excess bits upper manually."
			((mantissa digitAt: 1) = 2r01000000 and: [self anyBitOfMagnitudeFrom: 1 to: shift])
				ifTrue: [mantissa := mantissa + 1]]
		ifFalse:
			[mantissa := self.
			shift := 0].

	"There will be a single inexact round off at last iteration"
	result := (mantissa digitAt: (n := mantissa digitLength)) asFloat.
	[(n := n - 1) > 0] whileTrue: [
		result := 256.0 * result + (mantissa digitAt: n) asFloat].
	^result timesTwoPower: shift.! !
!LargePositiveInteger methodsFor: 'private' stamp: 'nice 12/30/2012 14:25'!
primitiveQuo: anInteger 
	"Primitive. Divide the receiver by the argument and return the result.
	Round the result down towards zero to make it a whole integer. Fail if
	the argument is 0. Fail if either the argument or the result is not a
	SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). Optional. See
	Object documentation whatIsAPrimitive."

	<primitive: 33>
	^nil! !
!LargePositiveInteger methodsFor: 'arithmetic' stamp: 'nice 12/30/2012 14:34'!
rem: aNumber 
	"Remainder defined in terms of quo:. See super rem:.
	This is defined only to speed up case of very large integers."

	(self primitiveQuo: aNumber)
		ifNotNil: [:quo | ^self - (quo * aNumber)].
	 aNumber isInteger
		ifTrue:
			[| ng rem |
			ng := self negative == aNumber negative == false.
			rem := (self digitDiv:
				(aNumber class == SmallInteger
					ifTrue: [aNumber abs]
					ifFalse: [aNumber])
				neg: ng) at: 2.
			^ rem normalize].
	^super rem: aNumber! !
!LargeNegativeInteger methodsFor: 'converting' stamp: 'nice 1/1/2013 15:42' prior: 37616204!
asFloat
	^super asFloat negated! !
!UndefinedObject methodsFor: 'class hierarchy' stamp: 'cwp 6/22/2012 15:39'!
literalScannedAs: scannedLiteral environment: anEnvironment notifying: requestor 
	^ scannedLiteral! !
!Behavior methodsFor: 'testing method dictionary' stamp: 'cwp 6/20/2012 17:32'!
bindingOf: varName environment: anEnvironment
	^superclass bindingOf: varName environment: anEnvironment! !
!Behavior methodsFor: 'testing method dictionary' stamp: 'cwp 6/20/2012 17:30'!
classBindingOf: varName environment: anEnvironment
	^self bindingOf: varName environment: anEnvironment! !
!Behavior methodsFor: 'printing' stamp: 'cwp 6/22/2012 15:37'!
literalScannedAs: scannedLiteral environment: anEnvironment notifying: requestor
	"Postprocesses a literal scanned by Scanner scanToken (esp. xLitQuote).
	If scannedLiteral is not an association, answer it.
	Else, if it is of the form:
		nil->#NameOfMetaclass
	answer nil->theMetaclass, if any has that name, else report an error.
	Else, if it is of the form:
		#NameOfGlobalVariable->anythiEng
	answer the global, class, or pool association with that nameE, if any, else
	add it to Undeclared a answer the new Association."

	| key value |
	(scannedLiteral isVariableBinding)
		ifFalse: [^ scannedLiteral].
	key := scannedLiteral key.
	value := scannedLiteral value.
	key ifNil: "###<metaclass soleInstance name>"
		[(self bindingOf: value environment: anEnvironment) ifNotNil:
			[:assoc|
			(assoc value isKindOf: Behavior) ifTrue: 
				[^ nil->assoc value class]].
			 requestor notify: 'No such metaclass'.
			 ^false].
	(key isSymbol) ifTrue: "##<global var name>"
		[(self bindingOf: key environment: anEnvironment) ifNotNil:
			[:assoc | ^assoc].
		^ anEnvironment undeclared: key].
	requestor notify: '## must be followed by a non-local variable name'.
	^false

"	Form literalScannedAs: 14 notifying: nil 14
	Form literalScannedAs: #OneBitForm notiEfying: nil  OneBitForm
	Form literalScannedAs: ##OneBitForm notifying: nil  OneBitForm->a Form
	Form literalScannedAs: ##Form notifying: nil   Form->Form
	Form literalScannedAs: ###Form notifying: nil   nilE->Form class
"! !
!Fraction methodsFor: 'converting' stamp: 'nice 11/21/2011 22:34' prior: 37619655!
asFloat
	"Answer a Float that closely approximates the value of the receiver.
	This implementation will answer the closest floating point number to the receiver.
	In case of a tie, it will use the IEEE 754 round to nearest even mode.
	In case of overflow, it will answer +/- Float infinity."

	| a b mantissa exponent hasTruncatedBits lostBit n ha hb hm |
	a := numerator abs.
	b := denominator.	"denominator is always positive"
	ha := a highBitOfMagnitude.
	hb := b highBitOfMagnitude.
	
	"Number of bits to keep in mantissa plus one to handle rounding."
	n := 1 + Float precision.

	"If both numerator and denominator are represented exactly in floating point number,
	then fastest thing to do is to use hardwired float division."
	(ha < n and: [hb < n]) ifTrue: [^numerator asFloat / denominator asFloat].

	"Shift the fraction by a power of two exponent so as to obtain a mantissa with n bits.
	First guess is rough, the mantissa might have n+1 bits."
	exponent := ha - hb - n.
	exponent >= 0
		ifTrue: [b := b bitShift: exponent]
		ifFalse: [a := a bitShift: exponent negated].
	mantissa := a quo: b.
	hasTruncatedBits := a > (mantissa * b).
	hm := mantissa highBit.
	
	"Check for gradual underflow, in which case the mantissa will loose bits.
	Keep at least one bit to let underflow preserve the sign of zero."
	lostBit := Float emin - (exponent + hm - 1).
	lostBit > 0 ifTrue: [n := n - lostBit max: 1].

	"Remove excess bits in the mantissa."
	hm > n
		ifTrue:
			[exponent := exponent + hm - n.
			hasTruncatedBits := hasTruncatedBits or: [mantissa anyBitOfMagnitudeFrom: 1 to: hm - n].
			mantissa := mantissa bitShift: n - hm].

	"Check if mantissa must be rounded upward.
	The case of tie (mantissa odd & hasTruncatedBits not)
	will be handled by Integer>>asFloat."
	(hasTruncatedBits and: [mantissa odd])
		ifTrue: [mantissa := mantissa + 1].

	^ (self positive
			ifTrue: [mantissa asFloat]
			ifFalse: [mantissa asFloat negated])
		timesTwoPower: exponent! !
!Float methodsFor: 'arithmetic' stamp: 'nice 12/20/2012 23:16' prior: 20878776!
negated
	"Answer a Number that is the negation of the receiver.
	Implementation note: this version cares of negativeZero."

	^-1.0 * self! !
!ClassDescription methodsFor: 'compiling' stamp: 'cwp 6/20/2012 17:21'!
compile: text environment: anEnvironment classified: category withStamp: changeStamp notifying: requestor
	^ self 
		compile: text 
		environment: anEnvironment 
		classified: category 
		withStamp: changeStamp 
		notifying: requestor 
		logSource: self acceptsLoggingOfCompilation! !
!ClassDescription methodsFor: 'compiling' stamp: 'cwp 12/27/2012 13:17'!
compile: text environment: anEnvironment classified: category withStamp: changeStamp notifying: requestor logSource: logSource
	| methodAndNode context methodNode |
	context := CompilationCue
		source: text
		class: self
		environment: anEnvironment
		category: category
		requestor: requestor.
	methodNode := self newCompiler compile: context ifFail: [^ nil].
	methodAndNode := CompiledMethodWithNode 
		generateMethodFromNode: methodNode 
		trailer: self defaultMethodTrailer.

	logSource ifTrue: [
		self logMethodSource: text forMethodWithNode: methodAndNode 
			inCategory: category withStamp: changeStamp notifying: requestor.
	].
	self addAndClassifySelector: methodAndNode selector withMethod: methodAndNode 
		method inProtocol: category notifying: requestor.
	self instanceSide noteCompilationOf: methodAndNode selector meta: self isClassSide.
	^ methodAndNode selector! !
!Class methodsFor: 'compiling' stamp: 'cwp 6/20/2012 09:47'!
bindingOf: varName environment: anEnvironment
	"Answer the binding of some variable resolved in the scope of the receiver"
	| aSymbol binding |
	aSymbol := varName asSymbol.

	"First look in classVar dictionary."
	binding := self classPool bindingOf: aSymbol.
	binding ifNotNil:[^binding].

	"Next look in shared pools."
	self sharedPools do:[:pool | 
		binding := pool bindingOf: aSymbol.
		binding ifNotNil:[^binding].
	].

	"Next look in declared environment."
	binding := anEnvironment bindingOf: aSymbol.
	binding ifNotNil:[^binding].

	"Finally look higher up the superclass chain and fail at the end."
	superclass == nil
		ifTrue: [^ nil]
		ifFalse: [^ superclass bindingOf: aSymbol].

! !

"Kernel"!

ParseNode subclass: #Encoder
	instanceVariableNames: 'scopeTable nTemps supered requestor class selector literalStream selectorSet litIndSet litSet sourceRanges globalSourceRanges addedSelectorAndMethodClassLiterals optimizedSelectors cue'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compiler-Kernel'!
!Encoder commentStamp: 'cwp 12/26/2012 23:29' prior: 36323851!
I encode names and literals into tree nodes with byte codes for the compiler. Byte codes for literals are not assigned until the tree-sizing pass of the compiler, because only then is it known which literals are actually needed. I also keep track of sourceCode ranges during parsing and code generation so I can provide an inverse map for the debugger.!

Scanner subclass: #Parser
	instanceVariableNames: 'here hereType hereMark hereEnd prevMark prevEnd encoder requestor parseNode failBlock requestorOffset tempsMark doitFlag properties category queriedUnusedTemporaries cue'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compiler-Kernel'!
!Parser commentStamp: 'cwp 12/26/2012 23:34' prior: 38557958!
I parse Smalltalk syntax and create a MethodNode that is the root of the parse tree. I look one token ahead.!

Object subclass: #CompilationCue
	instanceVariableNames: 'source context receiver class environment category requestor'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compiler-Kernel'!

Object subclass: #Compiler
	instanceVariableNames: 'sourceStream requestor class category context parser cue'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compiler-Kernel'!
!Compiler commentStamp: 'cwp 12/26/2012 23:17' prior: 59257505!
The compiler accepts Smalltalk source code and compiles it with respect to a given class. The user of the compiler supplies a context so that temporary variables are accessible during compilation. If there is an error, a requestor (usually a kind of StringHolderController) is sent the message notify:at:in: so that the error message can be displayed. If there is no error, then the result of compilation is a MethodNode, which is the root of a parse tree whose nodes are kinds of ParseNodes. The parse tree can be sent messages to (1) generate code for a CompiledMethod (this is done for compiling methods or evaluating expressions); (2) pretty-print the code (for formatting); or (3) produce a map from object code back to source code (used by debugger program-counter selection). See also Parser, Encoder, ParseNode.!
!Encoder methodsFor: 'initialize-release' stamp: 'cwp 12/26/2012 23:34'!
init: aCue notifying: anObject
	"The use of the variable requestor is a bit confusing here. This is
	*not* the original requestor, which is available through the cue.
	It's the Parser instance that is using the encoder."

	self setCue: aCue.
	requestor := anObject.
	nTemps := 0.
	supered := false.
	self initScopeAndLiteralTables.
	cue getClass variablesAndOffsetsDo:
		[:variable "<String|CFieldDefinition>" :offset "<Integer|nil>" |
		offset isNil
			ifTrue: [scopeTable at: variable name put: (FieldNode new fieldDefinition: variable)]
			ifFalse: [scopeTable
						at: variable
						put: (offset >= 0
								ifTrue: [InstanceVariableNode new
											name: variable index: offset]
								ifFalse: [MaybeContextInstanceVariableNode new
											name: variable index: offset negated])]].
	cue context ~~ nil ifTrue:
		[| homeNode |
		 homeNode := self bindTemp: self doItInContextName.
		 "0th temp = aContext passed as arg"
		 cue context tempNames withIndexDo:
			[:variable :index|
			scopeTable
				at: variable
				put: (MessageAsTempNode new
						receiver: homeNode
						selector: #namedTempAt:
						arguments: (Array with: (self encodeLiteral: index))
						precedence: 3
						from: self)]].
	sourceRanges := Dictionary new: 32.
	globalSourceRanges := OrderedCollection new: 32
! !
!Encoder methodsFor: 'private' stamp: 'cwp 12/26/2012 23:30'!
setCue: aCue
	cue := aCue.
	
	"Also set legacy instance variables for methods that
	don't use cue yet"
	class := cue getClass.! !
!Dictionary methodsFor: '*Compiler' stamp: 'cwp 6/22/2012 09:17'!
bindingOf: varName ifAbsent: aBlock

	^self associationAt: varName ifAbsent: aBlock! !
!Parser methodsFor: 'private' stamp: 'cwp 12/26/2012 23:37'!
init: sourceStream cue: aCue failBlock: aBlock

	self setCue: aCue.
	failBlock := aBlock.
	requestorOffset := 0.
	super scan: sourceStream.
	prevMark := hereMark := mark.
	self advance
! !
!Parser methodsFor: 'public access' stamp: 'cwp 12/26/2012 23:41'!
parse: sourceStream cue: aCue noPattern: noPattern ifFail: aBlock 
	"Answer a MethodNode for the argument, sourceStream, that is the root of
	 a parse tree. Parsing is done with respect to the CompilationCue to 
	 resolve variables. Errors in parsing are reported to the cue's requestor; 
	 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 subSelection |
	myStream := sourceStream.
	[repeatNeeded := false.
	 p := myStream position.
	 s := myStream upToEnd.
	 myStream position: p.
	 subSelection := aCue requestor notNil and: [aCue requestor selectionInterval = (p + 1 to: p + s size)].
	 self encoder init: aCue notifying: self.
	 self init: myStream cue: aCue failBlock: [^ aBlock value].
	 doitFlag := noPattern.
	 failBlock:= aBlock.
	 [methNode := self method: noPattern context: cue context] 
		on: ReparseAfterSourceEditing 
		do:	[ :ex |
			repeatNeeded := true.
			myStream := subSelection
							ifTrue:
								[ReadStream
									on: cue requestor text string
									from: cue requestor selectionInterval first
									to: cue requestor selectionInterval last]
							ifFalse:
								[ReadStream on: cue requestor text string]].
	 repeatNeeded] whileTrue:
		[encoder := self encoder class new].
	methNode sourceText: s.
	^methNode
! !
!Parser methodsFor: 'private' stamp: 'cwp 12/26/2012 23:35'!
setCue: aCue
	cue := aCue.
	
	"Also set legacy variables for methods that don't use cue yet."
	requestor := cue requestor.
	category := cue category.! !
!CompilationCue class methodsFor: 'instance creation' stamp: 'cwp 12/26/2012 23:53'!
class: aClass
	^ self 
		context: nil
		class: aClass
		requestor: nil! !
!CompilationCue class methodsFor: 'instance creation' stamp: 'cwp 12/26/2012 23:53'!
context: aContext class: aClass requestor: anObject
	^ self
		source: nil
		context: aContext
		receiver: nil
		class: aClass
		environment: (aClass ifNotNil: [aClass environment])
		category: nil
		requestor: anObject! !
!CompilationCue class methodsFor: 'instance creation' stamp: 'cwp 12/26/2012 23:16'!
source: aTextOrStream class: aClass environment: anEnvironment category: aString requestor: anObject
	^ self
		source: aTextOrStream
		context: nil
		receiver: nil
		class: aClass
		environment: anEnvironment
		category: aString
		requestor: anObject! !
!CompilationCue class methodsFor: 'instance creation' stamp: 'cwp 12/26/2012 23:53'!
source: aTextOrStream context: aContext class: aClass category: aString requestor: anObject
	^ self 
		source: aTextOrStream 
		context: aContext 
		receiver: (aContext ifNotNil: [aContext receiver])
		class: aClass 
		environment: (aClass ifNotNil: [aClass environment])
		category: aString 
		requestor: anObject! !
!CompilationCue class methodsFor: 'instance creation' stamp: 'cwp 12/26/2012 23:54'!
source: aTextOrStream context: aContext class: aClass requestor: anObject
	^ self 
		source: aTextOrStream 
		context: aContext 
		class: aClass 
		category: nil 
		requestor: anObject! !
!CompilationCue class methodsFor: 'instance creation' stamp: 'cwp 12/26/2012 23:55'!
source: aTextOrStream context: aContext receiver: recObject class: aClass environment: anEnvironment category: aString requestor: reqObject
	^ self basicNew
		initializeWithSource: aTextOrStream 
		context: aContext 
		receiver: recObject 
		class: aClass 
		environment: anEnvironment 
		category: aString 
		requestor: reqObject! !
!CompilationCue class methodsFor: 'instance creation' stamp: 'cwp 12/26/2012 23:16'!
source: aString environment: anEnvironment
	^ self 
		source: aString
		context: nil
		receiver: nil
		class: UndefinedObject
		environment: anEnvironment
		category: nil
		requestor: nil! !
!CompilationCue class methodsFor: 'instance creation' stamp: 'cwp 12/26/2012 23:54'!
source: aTextOrStream requestor: anObject
	^ self
		source: aTextOrStream
		context: nil
		class: nil
		requestor: anObject! !
!CompilationCue methodsFor: 'binding' stamp: 'cwp 6/20/2012 09:39'!
bindingOf: aSymbol
	^ class bindingOf: aSymbol environment: environment! !
!CompilationCue methodsFor: 'accessing' stamp: 'cwp 6/19/2012 11:15'!
category
	^ category! !
!CompilationCue methodsFor: 'accessing' stamp: 'cwp 12/26/2012 23:19'!
context
	^ context! !
!CompilationCue methodsFor: 'accessing' stamp: 'cwp 6/19/2012 11:15'!
environment
	^ environment! !
!CompilationCue methodsFor: 'accessing' stamp: 'cwp 6/19/2012 11:16'!
getClass
	^ class! !
!CompilationCue methodsFor: 'initialization' stamp: 'cwp 12/26/2012 23:16'!
initializeWithSource: aTextOrString context: aContext receiver: recObject class: aClass environment: anEnvironment category: aString requestor: reqObject
	self initialize.
	source := aTextOrString isStream ifTrue: [aTextOrString contents] ifFalse: [aTextOrString].
	context := aContext.
	receiver := recObject.
	class := aClass.
	environment := anEnvironment.
	category := aString.
	requestor := reqObject! !
!CompilationCue methodsFor: 'binding' stamp: 'cwp 6/22/2012 15:39'!
literalScannedAs: anObject notifying: anEncoder
	^ class literalScannedAs: anObject environment: environment notifying: anEncoder! !
!CompilationCue methodsFor: 'accessing' stamp: 'cwp 6/19/2012 11:15'!
receiver
	^ receiver! !
!CompilationCue methodsFor: 'accessing' stamp: 'cwp 6/19/2012 11:16'!
requestor
	^ requestor! !
!CompilationCue methodsFor: 'accessing' stamp: 'cwp 6/19/2012 11:15'!
source
	^ source! !
!CompilationCue methodsFor: 'accessing' stamp: 'cwp 6/19/2012 11:44'!
sourceStream
	^ source readStream! !
!Compiler class methodsFor: 'evaluating' stamp: 'cwp 6/20/2012 17:25'!
evaluate: aString environment: anEnvironment
	^ self 
		evaluate: aString 
		environment: anEnvironment 
		logged: false! !
!Compiler class methodsFor: 'evaluating' stamp: 'cwp 12/27/2012 12:36'!
evaluate: aString environment: anEnvironment logged: aBoolean
	| cue |
	cue := CompilationCue
		source: aString
		environment: anEnvironment.
		
	^ self new
		evaluate: aString
		cue: cue
		ifFail: [^ nil]
		logged: aBoolean! !
!Compiler methodsFor: 'public access' stamp: 'cwp 12/27/2012 13:18'!
compile: aCue ifFail: failBlock 
	"Answer a MethodNode. If the MethodNode can not be created, notify 
	the requestor in the contxt. If the requestor is nil, evaluate failBlock 
	instead. The MethodNode is the root  of a parse tree. It can be told 
	to generate a CompiledMethod to be installed in the method dictionary 
	of the class specified by the context."
	
	self setCue: aCue.
	self source: cue source.
	^self
		translate: sourceStream
		noPattern: false
		ifFail: failBlock! !
!Compiler methodsFor: 'public access' stamp: 'cwp 12/27/2012 00:06'!
evaluate: textOrStream cue: aCue ifFail: failBlock logged: logFlag
	"Compiles the sourceStream into a parse tree, then generates code into
	a method. Finally, the compiled method is invoked from here via 	withArgs:executeMethod:, hence the system no longer creates Doit method
	litter on errors."

	| methodNode method value toLog itsSelection itsSelectionString |
	self setCue: aCue.
	self source: textOrStream.
	methodNode := self translate: sourceStream noPattern: true ifFail: [^failBlock value].

	method := self interactive
				ifTrue: [methodNode generateWithTempNames]
				ifFalse: [methodNode generate].

	value := cue receiver
				withArgs: (cue context ifNil: [#()] ifNotNil: [{cue context}])
				executeMethod: method.

	logFlag ifTrue:
		[toLog := ((cue requestor respondsTo: #selection)  
			and:[(itsSelection := cue requestor selection) notNil
			and:[(itsSelectionString := itsSelection asString) isEmptyOrNil not]])
				ifTrue:[itsSelectionString]
				ifFalse:[sourceStream contents].
		SystemChangeNotifier uniqueInstance evaluated: toLog context: cue context].
	^ value
! !
!Compiler methodsFor: 'private' stamp: 'cwp 12/26/2012 23:20'!
setCue: aCue
	cue := aCue.
	
	"Set legacy instance variables for methods that don't use cue yet."
	requestor := cue requestor.
	class := cue getClass.
	category := cue category.
	context := cue context.! !
!Compiler methodsFor: 'private' stamp: 'cwp 6/19/2012 21:58'!
source: textOrStream
	sourceStream := (textOrStream isKindOf: PositionableStream)
		ifTrue: [ textOrStream ]
		ifFalse: [ ReadStream on: textOrStream asString ]! !

"Compiler"!
!SmartRefStream class methodsFor: 'i/o' stamp: 'cwp 6/20/2012 17:42'!
scanFrom: aByteStream environment: anEnvironment
	^ self scanFrom: aByteStream! !
!SmartRefStream methodsFor: 'read write' stamp: 'cwp 6/20/2012 17:41'!
scanFrom: aByteStream environment: anEnvironment
	^ self scanFrom: aByteStream! !
!ImageSegment methodsFor: 'fileIn/Out' stamp: 'cwp 6/20/2012 17:23'!
scanFrom: aStream environment: anEnvironment
	^ self scanFrom: aStream! !
!PseudoClass methodsFor: 'printing' stamp: 'cwp 6/22/2012 15:39'!
literalScannedAs: scannedLiteral environment: anEnvironment notifying: requestor 
	^ scannedLiteral! !
!InternalTranslator methodsFor: 'fileIn/fileOut' stamp: 'cwp 6/20/2012 17:34'!
scanFrom: aStream environment: anEnvironment
	"Read a definition of dictionary.  
	Make sure current locale corresponds my locale id"
	| aString newTranslations assoc currentPlatform |
	newTranslations := Dictionary new.
	currentPlatform := Locale currentPlatform.
	[Locale
		currentPlatform: (Locale localeID: id).
	[aString := aStream nextChunk withSqueakLineEndings.
	aString size > 0] whileTrue: 
		[assoc := Compiler evaluate: aString environment: anEnvironment.
		assoc value = ''
			ifTrue: [self class registerPhrase: assoc key]
			ifFalse: [newTranslations add: assoc]]]
		ensure: [Locale currentPlatform: currentPlatform].
	self mergeTranslations: newTranslations! !
!NaturalLanguageTranslator methodsFor: 'fileIn/fileOut' stamp: 'cwp 6/20/2012 17:26'!
scanFrom: aStream environment: anEnvironment
	"Read a definition of dictionary.  
	Make sure current locale corresponds my locale id"
	| newTranslations currentPlatform |
	newTranslations := Dictionary new.
	currentPlatform := Locale currentPlatform.
	[| aString assoc |
	Locale currentPlatform: (Locale localeID: id).
	[aString := aStream nextChunk withSqueakLineEndings.
	aString size > 0] whileTrue: 
		[assoc := Compiler evaluate: aString environment: anEnvironment.
		assoc value = ''
			ifTrue: [self class registerPhrase: assoc key]
			ifFalse: [newTranslations add: assoc]]]
		ensure: [Locale currentPlatform: currentPlatform].
	self mergeTranslations: newTranslations! !
!ObjectScanner methodsFor: 'scanning' stamp: 'cwp 6/20/2012 17:39'!
scanFrom: aByteStream environment: anEnvironment
	"This should probably be reimplemented using an environment
	for compilation. For now, don't change anything"
	^ self scanFrom: aByteStream! !
!SystemDictionary methodsFor: 'accessing' stamp: 'cwp 6/22/2012 09:16'!
bindingOf: varName ifAbsent: aBlock
	"SystemDictionary includes Symbols only"
	^super bindingOf: varName asSymbol ifAbsent: aBlock! !
!SystemDictionary methodsFor: 'accessing' stamp: 'cwp 6/22/2012 15:48'!
undeclared
	^ self at: #Undeclared! !

"System"!
!ExceptionTests methodsFor: 'testing-outer' stamp: 'fbs 1/1/2013 22:14' prior: 40840955!
expectedFailures
	^ #().! !

"Tests"!

ReleaseBuilder subclass: #ReleaseBuilderFor4dot5
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ReleaseBuilder'!
!ReleaseBuilderFor4dot5 commentStamp: 'fbs 1/1/2013 20:25' prior: 0!
The release builder for Squeak 4.5!
!ReleaseBuilder class methodsFor: 'scripts' stamp: 'fbs 12/31/2012 20:43'!
transferCurrentPackagesAsUser: username password: password
	"Copy the packages currently loaded in the image from the trunk repository to my releaseRepository."
	| trunkRep releaseRep |
	trunkRep := self trunkRepository.
	releaseRep := self releaseRepository
		user: username;
		password: password;
		yourself.
	MCWorkingCopy allManagers do:
		[ : eachWorkingCopy | eachWorkingCopy ancestors do:
			[ : eachVersionInfo | (releaseRep includesVersionNamed: eachVersionInfo versionName) ifFalse:
				[ (trunkRep versionWithInfo: eachVersionInfo)
					ifNil: [ Warning signal: eachVersionInfo name , ' not found in ', trunkRep ]
					ifNotNilDo: [ : ver | releaseRep storeVersion: ver ] ] ] ]! !
!ReleaseBuilderFor4dot5 class methodsFor: 'private' stamp: 'fbs 1/1/2013 20:23'!
openWelcomeWorkspaces
	TheWorldMainDockingBar instance
		showWelcomeText: #squeakUserInterface
		label: 'Squeak User Interface'
		in: (40 @ 40 extent: 500 @ 300).
	TheWorldMainDockingBar instance
		showWelcomeText: #workingWithSqueak
		label: 'Working With Squeak'
		in: (80 @ 80 extent: 500 @ 300).
	TheWorldMainDockingBar instance
		showWelcomeText: #licenseInformation
		label: 'License Information'
		in: (120 @ 120 extent: 500 @ 300).
	TheWorldMainDockingBar instance
		showWelcomeText: #welcomeFutureDirections
		label: 'Future Directions'
		in: (160 @ 160 extent: 500 @ 300).
	TheWorldMainDockingBar instance
		showWelcomeText: #welcomeToSqueak
		label: 'Welcome to Squeak 4.5'
		in: (200 @ 200 extent: 500 @ 300)! !
!ReleaseBuilderFor4dot5 class methodsFor: 'scripts' stamp: 'fbs 1/1/2013 20:22'!
prepareNewBuild
	super prepareNewBuild.
	MCMockPackageInfo initialize.! !
!ReleaseBuilderFor4dot5 class methodsFor: 'private' stamp: 'fbs 1/1/2013 20:24'!
releaseRepository
	"At release time, change 'trunk' to 'squeak45'."
	^ MCHttpRepository
		location: 'http://source.squeak.org/trunk'
		user: 'squeak'
		password: 'squeak'! !
!ReleaseBuilderFor4dot5 class methodsFor: 'private' stamp: 'fbs 1/1/2013 20:22'!
setDisplayExtent: extent
"Uncomment next line when the primitives become available in the Squeak VM."
"	DisplayScreen hostWindowSize: extent."
	Display extent = extent ifFalse: [ Warning signal: 'Display extent not set to ', extent ]! !
!ReleaseBuilderFor4dot5 class methodsFor: 'private' stamp: 'fbs 1/1/2013 20:23'!
setPreferences
	Preferences 
		installBrightWindowColors ;
		setPreference: #scrollBarsWithoutMenuButton toValue: true ;
		setPreference: #swapMouseButtons toValue: true ;
		setPreference: #annotationPanes toValue: true ;
		setPreference: #showSplitterHandles toValue: false ;
		setPreference: #showBoundsInHalo toValue: true ;
		setPreference: #alternateHandlesLook toValue: false ;
		setPreference: #roundedMenuCorners toValue: false ;
		setPreference: #roundedWindowCorners toValue: false.
	PluggableButtonMorph roundedButtonCorners: false.
	FillInTheBlankMorph roundedDialogCorners: false.
	Workspace shouldStyle: false.
	NetNameResolver enableIPv6: true.! !
!ReleaseBuilderFor4dot5 class methodsFor: 'private' stamp: 'fbs 1/1/2013 20:23'!
switchToNewRepository
	| old44Repository |
	MCMcmUpdater defaultUpdateURL: self releaseRepository description.
	old44Repository := MCRepositoryGroup default repositories
				detect: [:each | each description includesSubString: 'squeak44'] ifNone: [nil].
	old44Repository
		ifNotNil: [MCRepositoryGroup default removeRepository: old44Repository].
	MCRepositoryGroup default addRepository: self releaseRepository! !
!ReleaseBuilderFor4dot5 class methodsFor: 'private' stamp: 'fbs 1/1/2013 20:23'!
versionString
	^ 'Squeak4.5'.! !

ReleaseBuilder class removeSelector: #transferCurrentPackages!

"ReleaseBuilder"!
!Environment class methodsFor: 'as yet unclassified' stamp: 'cwp 1/1/2013 18:52' prior: 40834114!
initialize
	self install! !

"Environments"!
!Parser methodsFor: 'private' stamp: 'cwp 12/26/2012 23:59' prior: 52081878!
initPattern: aString notifying: req return: aBlock

	| result |
	self
		init: (ReadStream on: aString asString)
		cue: (CompilationCue source: aString requestor: req)
		failBlock: [^nil].
	encoder := self.
	result := aBlock value: (self pattern: false inContext: nil).
	encoder := failBlock := nil.  "break cycles"
	^result! !
!Parser methodsFor: 'public access' stamp: 'cwp 12/27/2012 00:01' prior: 34175471!
parse: sourceStream class: class category: aCategory noPattern: noPattern context: aContext notifying: req ifFail: aBlock 
	| c |
	c := CompilationCue
			source: sourceStream
			context: aContext
			class: class
			category: aCategory
			requestor: req.
	^ self 
		parse: sourceStream 
		cue: c 
		noPattern: noPattern 
		ifFail: aBlock! !
!Compiler methodsFor: 'public access' stamp: 'cwp 12/27/2012 09:11' prior: 34183963!
evaluate: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock logged: logFlag
	"Compiles the sourceStream into a parse tree, then generates code into
	 a method. If aContext is not nil, the text can refer to temporaries in that
	 context (the Debugger uses this). If aRequestor is not nil, then it will receive
	 a notify:at: message before the attempt to evaluate is aborted. Finally, the 
	 compiled method is invoked from here via withArgs:executeMethod:, hence
	 the system no longer creates Doit method litter on errors."
	
	| theClass |
	theClass := ((aContext == nil ifTrue: [receiver] ifFalse: [aContext receiver]) class).
	self setCue: (CompilationCue
		source: textOrStream
		context: aContext
		receiver: receiver
		class: theClass
		environment: theClass environment
		category: nil
		requestor: aRequestor).
	^ self evaluate: textOrStream cue: cue ifFail: failBlock logged: logFlag! !
!Compiler methodsFor: 'public access' stamp: 'cwp 12/27/2012 09:17' prior: 34185488!
from: textOrStream class: aClass classified: aCategory context: aContext notifying: req
	self source: textOrStream.
	self setCue: 
		(CompilationCue
			source: textOrStream
			context: aContext
			class: aClass
			category: aCategory
			requestor: req)! !
!Compiler methodsFor: 'private' stamp: 'cwp 12/26/2012 23:55' prior: 50781309!
from: textOrStream class: aClass context: aContext notifying: req
	self source: textOrStream.
	self setCue:
		(CompilationCue
			source: textOrStream
			context: aContext
			class: aClass
			requestor: req)
! !
!Encoder methodsFor: 'initialize-release' stamp: 'cwp 12/27/2012 09:41' prior: 50996506!
init: aClass context: aContext notifying: anObject
	| c |
	c := CompilationCue
		context: aContext 
		class: aClass 
		requestor: nil.
	self init: c notifying: anObject! !
!Encoder methodsFor: 'initialize-release' stamp: 'cwp 12/26/2012 23:58' prior: 39061698!
temps: tempVars literals: lits class: cl 
	"Initialize this encoder for decompilation."

	self setCue: (CompilationCue class: cl).
	supered := false.
	nTemps := tempVars size.
	tempVars do: [:node | scopeTable at: node name put: node].
	literalStream := WriteStream on: (Array new: lits size).
	literalStream nextPutAll: lits.
	sourceRanges := Dictionary new: 32.
	globalSourceRanges := OrderedCollection new: 32.! !

"Compiler"!
!Class methodsFor: 'class variables' stamp: 'cwp 6/22/2012 15:48' prior: 36026010!
addClassVarName: aString 
	"Add the argument, aString, as a class variable of the receiver.
	Signal an error if the first character of aString is not capitalized,
	or if it is already a variable named in the class."
	| symbol oldState |
	oldState := self copy.
	aString first canBeGlobalVarInitial
		ifFalse: [^self error: aString, ' class variable name should be capitalized; proceed to include anyway.'].
	symbol := aString asSymbol.
	self withAllSubclasses do: 
		[:subclass | 
		(self canFindWithoutEnvironment: symbol) ifTrue: [
			(DuplicateVariableError new)
				superclass: superclass; "fake!!!!!!"
				variable: aString;
				signal: aString, ' is already defined']].
	classPool == nil ifTrue: [classPool := Dictionary new].
	(classPool includesKey: symbol) ifFalse: 
		["Pick up any refs in Undeclared"
		classPool declare: symbol from: environment undeclared.
		SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: oldState to: self]! !
!Class methodsFor: 'compiling' stamp: 'cwp 6/20/2012 09:48' prior: 54782024!
bindingOf: varName
	^ self bindingOf: varName environment: self environment! !
!Class methodsFor: 'organization' stamp: 'cwp 6/25/2012 18:25' prior: 54785804!
category
	"Answer the system organization category for the receiver. First check whether the
	category name stored in the ivar is still correct and only if this fails look it up
	(latter is much more expensive)"

	category ifNotNil: [ :symbol |
		((self environment organization listAtCategoryNamed: symbol) includes: self name)
			ifTrue: [ ^symbol ] ].
	category := self environment organization categoryOfElement: self name.
	^category! !
!Class methodsFor: 'initialize-release' stamp: 'cwp 6/22/2012 15:49' prior: 36027730!
declare: varString 
	"Declare class variables common to all instances. Answer whether 
	recompilation is advisable."

	| newVars conflicts |
	
	newVars := 
		(Scanner new scanFieldNames: varString)
			collect: [:x | x asSymbol].
	newVars do:
		[:var | var first canBeGlobalVarInitial
			ifFalse: [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 canFindWithoutEnvironment: var) ifTrue: [
					(DuplicateVariableError new)
						superclass: superclass; "fake!!!!!!"
						variable: var;
						signal: var, ' is already defined'.
					conflicts := true]].
	newVars size > 0
		ifTrue: 
			[classPool := self classPool.
			"in case it was nil"
			newVars do: [:var | classPool declare: var from: environment undeclared]].
	^conflicts! !
!Class methodsFor: 'class variables' stamp: 'cwp 6/22/2012 15:49' prior: 54802475!
removeClassVarName: aString 
	"Remove the class variable whose name is the argument, aString, from 
	the names defined in the receiver, a class. Create an error notification if 
	aString is not a class variable or if it is still being used in the code of 
	the class."

	| aSymbol |
	aSymbol := aString asSymbol.
	(classPool includesKey: aSymbol)
		ifFalse: [^self error: aString, ' is not a class variable'].
	self withAllSubclasses do:[:subclass |
		(Array with: subclass with: subclass class) do:[:classOrMeta |
			(classOrMeta whichSelectorsReferTo: (classPool associationAt: aSymbol))
				isEmpty ifFalse: [
					InMidstOfFileinNotification signal ifTrue: [
						Transcript cr; show: self name, ' (' , aString , ' is Undeclared) '.
						^ environment undeclared declare: aSymbol from: classPool].
					(self confirm: (aString,' is still used in code of class ', classOrMeta name,
						'.\Is it okay to move it to Undeclared?') withCRs)
						ifTrue:[^Undeclared declare: aSymbol from: classPool]
						ifFalse:[^self]]]].
	classPool removeKey: aSymbol.
	classPool isEmpty ifTrue: [classPool := nil].
! !
!Class methodsFor: 'class name' stamp: 'cwp 6/22/2012 15:49' prior: 54796206!
rename: aString 
	"The new name of the receiver is the argument, aString."

	| oldName newName |
	(newName := aString asSymbol) = (oldName := self name)
		ifTrue: [^ self].
	(self environment includesKey: newName)
		ifTrue: [^ self error: newName , ' already exists'].
	(environment undeclared includesKey: newName)
		ifTrue: [self inform: 'There are references to, ' , aString printString , '
from Undeclared. Check them after this change.'].
	name := newName.
	self environment renameClass: self from: oldName! !
!ClassBuilder methodsFor: 'class definition' stamp: 'cwp 6/22/2012 01:05' prior: 39054430!
name: className inEnvironment: env subclassOf: newSuper type: type instanceVariableNames: instVarString classVariableNames: classVarString poolDictionaries: poolString category: category unsafe: unsafe
	"Define a new class in the given environment.
	If unsafe is true do not run any validation checks.
	This facility is provided to implement important system changes."
	| oldClass instVars classVars copyOfOldClass newClass |
 
	environ := env.
	instVars := Scanner new scanFieldNames: instVarString.
	classVars := (Scanner new scanFieldNames: classVarString) collect: [:x | x asSymbol].

	"Validate the proposed name"
	unsafe ifFalse:[(self validateClassName: className) ifFalse:[^nil]].
	oldClass := env at: className ifAbsent:[nil].
	oldClass isBehavior 
		ifFalse: [oldClass := nil]  "Already checked in #validateClassName:"
		ifTrue: [
			copyOfOldClass := oldClass copy.
			copyOfOldClass superclass addSubclass: copyOfOldClass].
	
	
	[ | newCategory needNew force organization oldCategory |
	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.
		newClass environment: environ.
	] 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 := environ ifNotNil:[environ organization].
	oldClass isNil ifFalse: [oldCategory := (organization categoryOfElement: oldClass name) asSymbol].
	organization classify: newClass name under: newCategory suppressIfDefault: true.
	
	"... recompile ..."
	newClass := self recompile: force from: oldClass to: newClass mutate: false.

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


	newClass doneCompiling.
	"... notify interested clients ..."
	oldClass isNil ifTrue: [
		SystemChangeNotifier uniqueInstance classAdded: newClass inCategory: newCategory.
		^ newClass].
	newCategory ~= oldCategory 
		ifTrue: [SystemChangeNotifier uniqueInstance class: newClass recategorizedFrom: oldCategory to: category]
		ifFalse: [SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfOldClass to: newClass.].
] ensure: 
		[copyOfOldClass ifNotNil: [copyOfOldClass superclass removeSubclass: copyOfOldClass].
		Behavior flushObsoleteSubclasses.
		].
	^newClass! !
!ClassBuilder methodsFor: 'public' stamp: 'cwp 6/19/2012 22:57' prior: 18572019!
superclass: newSuper
	subclass: t instanceVariableNames: f 
	classVariableNames: d poolDictionaries: s category: cat 
	"This is the standard initialization message for creating a new class as a 
	subclass of an existing class."
	| env |
	env := EnvironmentRequest signal ifNil: [newSuper environment].
	^self 
		name: t
		inEnvironment: env
		subclassOf: newSuper
		type: newSuper typeOfClass
		instanceVariableNames: f
		classVariableNames: d
		poolDictionaries: s
		category: cat! !
!ClassBuilder methodsFor: 'public' stamp: 'cwp 6/19/2012 23:01' prior: 50629912!
superclass: aClass
	variableByteSubclass: t instanceVariableNames: f 
	classVariableNames: d poolDictionaries: s category: cat
	"This is the standard initialization message for creating a new class as a 
	subclass of an existing class in which the subclass is to 
	have indexable byte-sized nonpointer variables."
	| oldClassOrNil actualType env |
	(aClass instSize > 0)
		ifTrue: [^self error: 'cannot make a byte subclass of a class with named fields'].
	(aClass isVariable and: [aClass isWords])
		ifTrue: [^self error: 'cannot make a byte subclass of a class with word fields'].
	(aClass isVariable and: [aClass isPointers])
		ifTrue: [^self error: 'cannot make a byte subclass of a class with pointer fields'].
	oldClassOrNil := aClass environment at: t ifAbsent:[nil].
	actualType := (oldClassOrNil notNil
				   and: [oldClassOrNil typeOfClass == #compiledMethod])
					ifTrue: [#compiledMethod]
					ifFalse: [#bytes].
	env := EnvironmentRequest signal ifNil: [aClass environment].
	^self 
		name: t
		inEnvironment: env
		subclassOf: aClass
		type: actualType
		instanceVariableNames: f
		classVariableNames: d
		poolDictionaries: s
		category: cat! !
!ClassBuilder methodsFor: 'public' stamp: 'cwp 6/19/2012 23:03' prior: 18573442!
superclass: aClass
	variableSubclass: t instanceVariableNames: f 
	classVariableNames: d poolDictionaries: s category: cat
	"This is the standard initialization message for creating a new class as a 
	subclass of an existing class in which the subclass is to 
	have indexable pointer variables."
	
	| env |
	aClass isBits ifTrue: 
		[^self error: 'cannot make a pointer subclass of a class with non-pointer fields'].
	env := EnvironmentRequest signal ifNil: [aClass environment].
	^self 
		name: t
		inEnvironment: env
		subclassOf: aClass
		type: #variable
		instanceVariableNames: f
		classVariableNames: d
		poolDictionaries: s
		category: cat! !
!ClassBuilder methodsFor: 'public' stamp: 'cwp 6/19/2012 23:04' prior: 18574098!
superclass: aClass
	variableWordSubclass: t instanceVariableNames: f 
	classVariableNames: d poolDictionaries: s category: cat
	"This is the standard initialization message for creating a new class as a 
	subclass of an existing class in which the subclass is to 
	have indexable word-sized nonpointer variables."
	| env |
	(aClass instSize > 0)
		ifTrue: [^self error: 'cannot make a word subclass of a class with named fields'].
	(aClass isVariable and: [aClass isBytes])
		ifTrue: [^self error: 'cannot make a word subclass of a class with byte fields'].
	(aClass isVariable and: [aClass isPointers])
		ifTrue: [^self error: 'cannot make a word subclass of a class with pointer fields'].
	env := EnvironmentRequest signal ifNil: [aClass environment].
	^self 
		name: t
		inEnvironment: env
		subclassOf: aClass
		type: #words
		instanceVariableNames: f
		classVariableNames: d
		poolDictionaries: s
		category: cat! !
!ClassBuilder methodsFor: 'public' stamp: 'cwp 6/19/2012 23:04' prior: 18575028!
superclass: aClass
	weakSubclass: t instanceVariableNames: f 
	classVariableNames: d poolDictionaries: s category: cat
	"This is the standard initialization message for creating a new class as a 
	subclass of an existing class (the receiver) in which the subclass is to 
	have weak indexable pointer variables."
	| env |
	aClass isBits 
		ifTrue: [^self error: 'cannot make a pointer subclass of a class with non-pointer fields'].
	env := EnvironmentRequest signal ifNil: [aClass environment].
	^self 
		name: t
		inEnvironment: env
		subclassOf: aClass
		type: #weak
		instanceVariableNames: f
		classVariableNames: d
		poolDictionaries: s
		category: cat! !

"Kernel"!
!Parser methodsFor: 'error correction' stamp: 'cwp 12/27/2012 10:21' prior: 59135029!
ambiguousSelector: aString inRange: anInterval
	| correctedSelector userSelection offset intervalWithOffset |
	
	self interactive ifFalse: [
		"In non interactive mode, compile with backward comapatibility: $- is part of literal argument"
		Transcript cr; store: encoder classEncoding; nextPutAll:#'>>';store: encoder selector; show: ' would send ' , token , '-'.
		^super ambiguousSelector: aString inRange: anInterval].
	
	"handle the text selection"
	userSelection := cue requestor selectionInterval.
	intervalWithOffset := anInterval first + requestorOffset to: anInterval last + requestorOffset.
	cue requestor selectFrom: intervalWithOffset first to: intervalWithOffset last.
	cue requestor select.

	"Build the menu with alternatives"
	correctedSelector := AmbiguousSelector 
			signalName: aString
			inRange: intervalWithOffset.
	correctedSelector ifNil: [^self fail].

	"Execute the selected action"
	offset := self substituteWord: correctedSelector wordInterval: intervalWithOffset offset: 0.
	cue requestor deselect.
	cue requestor selectInvisiblyFrom: userSelection first to: userSelection last + offset.
	token := (correctedSelector readStream upTo: Character space) asSymbol! !
!Parser methodsFor: 'error correction' stamp: 'cwp 12/27/2012 10:21' prior: 38558136!
collectTemporaryDeclarationsFrom: methodNode
	| tempsMarks str |
	tempsMarks := OrderedCollection new.
	str := cue requestor text asString.
	methodNode accept: (ParseNodeEnumerator
		ofBlock: [ :aNode | 
			| mark |
			(aNode class canUnderstand: #tempsMark) 
				ifTrue: 
					[mark := aNode tempsMark.
					(mark notNil and: [ mark between: 1 and: str size ] and: [ (str at: mark) = $| ])
						ifTrue: [ tempsMarks addLast: aNode ]]]).
	(tempsMark notNil and: [ tempsMark between: 1 and: str size ] and: [ (str at: tempsMark) = $| ])
						ifTrue: [ tempsMarks addLast: self ].
	^ tempsMarks sorted: [ :a :b | a tempsMark > b tempsMark ]! !
!Parser methodsFor: 'error correction' stamp: 'cwp 12/27/2012 10:20' prior: 52096606!
correctSelector: proposedKeyword wordIntervals: spots exprInterval: expInt ifAbort: abortAction
	"Correct the proposedKeyword to some selector symbol, correcting the original text if such action is indicated.  abortAction is invoked if the proposedKeyword couldn't be converted into a valid selector.  Spots is an ordered collection of intervals within the test stream of the for each of the keyword parts."

	| correctSelector userSelection |
	"If we can't ask the user, assume that the keyword will be defined later"
	self interactive ifFalse: [^proposedKeyword asSymbol].

	userSelection := cue requestor selectionInterval.
	cue requestor selectFrom: spots first first to: spots last last.
	cue requestor select.

	correctSelector := UnknownSelector name: proposedKeyword.
	correctSelector ifNil: [^abortAction value].

	cue requestor deselect.
	cue requestor selectInvisiblyFrom: userSelection first to: userSelection last.

	self substituteSelector: correctSelector keywords wordIntervals: spots.
	^(proposedKeyword last ~~ $:
	   and: [correctSelector last == $:])
		ifTrue: [abortAction value]
		ifFalse: [correctSelector]! !
!Parser methodsFor: 'error correction' stamp: 'cwp 12/27/2012 10:20' prior: 33907242!
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. "

	"Check if this is an i-var, that has been corrected already (ugly)"

	"Display the pop-up menu"

	| binding userSelection action |
	(encoder classEncoding instVarNames includes: proposedVariable) ifTrue: 
		[^InstanceVariableNode new 
			name: proposedVariable
			index: (encoder classEncoding allInstVarNames indexOf: proposedVariable)].

	"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"
	(binding := cue requestor bindingOf: proposedVariable)
		ifNotNil: [^encoder global: binding name: proposedVariable].
	userSelection := cue requestor selectionInterval.
	cue requestor selectFrom: spot first to: spot last.
	cue requestor select.

	"Build the menu with alternatives"
	action := UndeclaredVariable 
				signalFor: self
				name: proposedVariable
				inRange: spot.
	action ifNil: [^self fail].

	"Execute the selected action"
	cue requestor deselect.
	cue requestor selectInvisiblyFrom: userSelection first to: userSelection last.
	^action value! !
!Parser methodsFor: 'error correction' stamp: 'cwp 12/27/2012 10:19' prior: 34172921!
declareUndeclaredTemps: methodNode
	"Declare any undeclared temps, declaring them at the smallest enclosing scope."

	| undeclared userSelection blocksToVars |
	(undeclared := encoder undeclaredTemps) isEmpty ifTrue:
		[^self].
	userSelection := cue requestor selectionInterval.
	blocksToVars := IdentityDictionary new.
	undeclared do:
		[:var|
		(blocksToVars
			at: (var tag == #method
					ifTrue: [methodNode block]
					ifFalse: [methodNode accept: (VariableScopeFinder new ofVariable: var)])
			ifAbsentPut: [SortedCollection new]) add: var name].
	(blocksToVars removeKey: methodNode block ifAbsent: []) ifNotNil:
		[:rootVars|
		rootVars do: [:varName| self pasteTempAtMethodLevel: varName]].
	(blocksToVars keys sorted: [:a :b| a tempsMark < b tempsMark]) do:
		[:block| | decl |
		decl := (blocksToVars at: block) reduce: [:a :b| a, ' ', b].
		block temporaries isEmpty
			ifTrue:
				[self substituteWord: ' | ', decl, ' |'
					wordInterval: (block tempsMark + 1 to: block tempsMark)
					offset: requestorOffset]
			ifFalse:
				[self substituteWord: decl, ' '
					wordInterval: (block tempsMark to: block tempsMark - 1)
					offset: requestorOffset]].
	cue requestor selectInvisiblyFrom: userSelection first to: userSelection last + requestorOffset.
	ReparseAfterSourceEditing signal! !
!Parser methodsFor: 'error correction' stamp: 'cwp 12/27/2012 11:45' prior: 37183770!
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 := UIManager default request: 'Enter class category : ' initialAnswer: self encoder classEncoding theNonMetaClass category.
	cat
		ifEmpty: [cat := 'Unknown'].
	def := 'Object subclass: #' , sym , '
		instanceVariableNames: '''' 
		classVariableNames: ''''
		poolDictionaries: ''''
		category: ''' , cat , ''''.
	d2 := UIManager default request: 'Edit class definition : ' initialAnswer: def.
	d2
		ifEmpty: [d2 := def].
	Compiler evaluate: d2.
	^ encoder
		global: (cue environment bindingOf: sym)
		name: sym! !
!Parser methodsFor: 'primitives' stamp: 'cwp 12/27/2012 11:46' prior: 37184567!
externalFunctionDeclaration
	"Parse the function declaration for a call to an external library."
	| descriptorClass callType modifier retType externalName args argType module fn |
	descriptorClass := cue environment
		valueOf: #ExternalFunction 
		ifAbsent: [^ false].
	callType := descriptorClass callingConventionFor: here.
	callType == nil ifTrue:[^false].
	[modifier := descriptorClass callingConventionModifierFor: token.
	 modifier notNil] whileTrue:
		[self advance.
		 callType := callType bitOr: modifier].
	"Parse return type"
	self advance.
	retType := self externalType: descriptorClass.
	retType == nil ifTrue:[^self expected:'return type'].
	"Parse function name or index"
	externalName := here.
	(self match: #string) 
		ifTrue:[externalName := externalName asSymbol]
		ifFalse:[(self match:#number) ifFalse:[^self expected:'function name or index']].
	(self matchToken: #'(') ifFalse:[^self expected:'argument list'].
	args := WriteStream on: Array new.
	[here == #')'] whileFalse:[
		argType := self externalType: descriptorClass.
		argType == nil ifTrue:[^self expected:'argument'].
		argType isVoid & argType isPointerType not ifFalse:[args nextPut: argType].
	].
	(self matchToken: #')') ifFalse:[^self expected:')'].
	(self matchToken: 'module:') ifTrue:[
		module := here.
		(self match: #string) ifFalse:[^self expected: 'String'].
		module := module asSymbol].
	Smalltalk at: #ExternalLibraryFunction ifPresent:[:xfn|
		fn := xfn name: externalName 
				module: module 
				callType: callType
				returnType: retType
				argumentTypes: args contents.
		self allocateLiteral: fn.
	].
	(self matchToken: 'error:')
		ifTrue:
			[| errorCodeVariable |
			 errorCodeVariable := here.
			(hereType == #string
			 or: [hereType == #word]) ifFalse:[^self expected: 'error code (a variable or string)'].
			 self advance.
			 self addPragma: (Pragma keyword: #primitive:error: arguments: (Array with: 120 with: errorCodeVariable)).
			 fn ifNotNil: [fn setErrorCodeName: errorCodeVariable]]
		ifFalse:
			[self addPragma: (Pragma keyword: #primitive: arguments: #(120))].
	^true
! !
!Parser methodsFor: 'error handling' stamp: 'cwp 12/27/2012 10:19' prior: 58306169!
interactive
	"Answer true if compilation is interactive"

	^ cue requestor notNil! !
!Parser methodsFor: 'error handling' stamp: 'cwp 12/27/2012 10:22' prior: 58137223!
notify: string at: location
	cue requestor isNil
		ifTrue: [(encoder == self or: [encoder isNil]) ifTrue: [^ self fail  "failure setting up syntax error"].
				SyntaxErrorNotification
					inClass: encoder classEncoding
					category: cue category
					withCode: 
						(source contents asText
							copyReplaceFrom: location
							to: location - 1
							with: ((string , ' ->') asText allBold 
								addAttribute: TextColor red; yourself))
					doitFlag: doitFlag
					errorMessage: string
					location: location]
		ifFalse: [cue requestor
					notify: string , ' ->'
					at: location
					in: source].
	^self fail! !
!Parser methodsFor: 'error correction' stamp: 'cwp 12/27/2012 10:17' prior: 34177108!
pasteTempAtMethodLevel: name
	| insertion delta theTextString characterBeforeMark |

	theTextString := cue requestor text string.
	characterBeforeMark := theTextString at: tempsMark-1 ifAbsent: [$ ].
	(theTextString at: tempsMark) = $| ifTrue: [
  		"Paste it before the second vertical bar"
		insertion := name, ' '.
		characterBeforeMark isSeparator ifFalse: [
insertion := ' ', insertion].
		delta := 0.
	] ifFalse: [
		"No bars - insert some with CR, tab"
		insertion := '| ' , name , ' |',String cr.
		delta := 2.	"the bar and CR"
		characterBeforeMark = Character tab ifTrue: [
			insertion := insertion , String tab.
			delta := delta + 1.	"the tab"
		].
	].
	tempsMark := tempsMark +
		(self substituteWord: insertion
			wordInterval: (tempsMark to: tempsMark-1)
			offset: 0) - delta! !
!Parser methodsFor: 'error correction' stamp: 'cwp 12/27/2012 10:16' prior: 52095305!
queryUndefined
	| varStart varName | 
	varName := parseNode key.
	varStart := self endOfLastToken + requestorOffset - varName size + 1.
	cue requestor selectFrom: varStart to: varStart + varName size - 1; select.
	(UndefinedVariable name: varName) ifFalse: [^ self fail]! !
!Parser methodsFor: 'error correction' stamp: 'cwp 12/27/2012 10:15' prior: 38599341!
removeEmptyTempDeclarationsFrom: methodNode

	| sourceCode madeChanges tempsMarkHolder |
	sourceCode := cue requestor text asString.
	tempsMarkHolder := self collectTemporaryDeclarationsFrom: methodNode.
	madeChanges := false.
	tempsMarkHolder do: [ :currentBlock | | tempsMarkChar0 tempsMarkChar1 tempsMarkChar2 end start |
		tempsMarkChar0 := (sourceCode at: currentBlock tempsMark).
		tempsMarkChar1 := (sourceCode at: currentBlock tempsMark - 1).
		tempsMarkChar2 := (sourceCode at: currentBlock tempsMark - 2).
		tempsMarkChar0 = $| & tempsMarkChar1 = $| 
			ifTrue: 
				[ end := currentBlock tempsMark. 
				start := end - 1].
		tempsMarkChar0 = $| & tempsMarkChar1 = $  & tempsMarkChar2 = $| 
			ifTrue: 
				[ end := currentBlock tempsMark. 
				start := end - 2].
		
		start notNil & end notNil ifTrue: [
			| lineStart lineEnd |
			lineStart := 1 + (sourceCode 
				lastIndexOf: Character cr 
				startingAt: start - 1
				ifAbsent: [ 0 ]).
			lineEnd := sourceCode 
				indexOf: Character cr
				startingAt: end + 1
				ifAbsent: [ sourceCode size ].
			((sourceCode indexOfAnyOf: CharacterSet nonSeparators startingAt: lineStart) >= start 
				and: [ (sourceCode indexOfAnyOf: CharacterSet nonSeparators startingAt: end + 1) > lineEnd ]) ifTrue: [
					start := lineStart.
					end := lineEnd ].
			cue requestor correctFrom: start to: end with: ''.
			madeChanges := true.
			currentBlock tempsMark: nil ] ].
	madeChanges ifTrue: [ReparseAfterSourceEditing signal]! !
!Parser methodsFor: 'error correction' stamp: 'cwp 12/27/2012 10:15' prior: 38561281!
removeUnusedTemporaryNamed: temp from: str lookingAt: currentBlock movingTempMarksOf: someBlocks

	| start end |
	end := currentBlock tempsMark - 1.
	["Beginning at right temp marker..."
	start := end - temp size + 1.
	end < temp size or: [ (str at: start) = $| ]
		or: [ temp = (str copyFrom: start to: end) 
			and: [ ((str at: start - 1) = $| | (str at: start - 1) isSeparator) 
				& ((str at: end + 1) = $| | (str at: end + 1) isSeparator) ] ]]
		whileFalse: [ 
			"Search left for the unused temp"
			end := cue requestor nextTokenFrom: end direction: -1 ].
	(end < temp size or: [ (str at: start) = $| ])
		ifFalse: 
			[(str at: start - 1) = $ 
				ifTrue: [ start := start - 1 ].
			cue requestor correctFrom: start to: end with: ''.
			someBlocks do: [ :aBlock | aBlock tempsMark: aBlock tempsMark - (end - start + 1)].
			^true ].
	^false! !
!Parser methodsFor: 'error correction' stamp: 'cwp 12/27/2012 10:14' prior: 38562194!
removeUnusedTemps: methodNode
	"Scan for unused temp names, and prompt the user about the prospect of removing each one found"

	| madeChanges tempsMarkHolder unusedTempNames tempMarkHoldersToChange |
	madeChanges := false.
	tempMarkHoldersToChange := OrderedCollection new.
	tempsMarkHolder := self collectTemporaryDeclarationsFrom: methodNode.
	unusedTempNames := encoder unusedTempNames select: 
		[ :temp | (encoder lookupVariable: temp ifAbsent: [ ]) isUndefTemp 
				and: [ self queriedUnusedTemporaries at: temp ifAbsentPut: [UnusedVariable name: temp] ]].
	tempsMarkHolder do: [ :currentBlock | 
		tempMarkHoldersToChange add: currentBlock.
		unusedTempNames do: 
			[ :temp |
			(self 
				removeUnusedTemporaryNamed: temp 
				from: cue requestor text asString 
				lookingAt: currentBlock
				movingTempMarksOf: tempMarkHoldersToChange) ifTrue: [ madeChanges := true ]]].
	madeChanges
		ifTrue: [ self removeEmptyTempDeclarationsFrom: methodNode.
			ReparseAfterSourceEditing signal ]! !
!Parser methodsFor: 'error correction' stamp: 'cwp 12/27/2012 10:14' prior: 34179326!
substituteWord: correctWord wordInterval: spot offset: o
	"Substitute the correctSelector into the (presumed interactive) receiver.
	 Update requestorOffset based on the delta size and answer the updated offset."

	cue requestor correctFrom: spot first + o to: spot last + o with: correctWord.
	requestorOffset := requestorOffset + correctWord size - spot size.
	^o + correctWord size - spot size! !
!Parser methodsFor: 'expression types' stamp: 'cwp 12/27/2012 10:14' prior: 34179807!
temporaries
	" [ '|' (variable)* '|' ]"
	| vars theActualText |
	(self match: #verticalBar) ifFalse: 
		["no temps"
		doitFlag ifTrue:
			[tempsMark := self interactive
								ifTrue: [cue requestor selectionInterval first]
								ifFalse: [1].
			^ #()].
		tempsMark := hereMark	"formerly --> prevMark + prevToken".
		tempsMark > 0 ifTrue:
			[theActualText := source contents.
			[tempsMark < theActualText size and: [(theActualText at: tempsMark) isSeparator]]
				whileTrue: [tempsMark := tempsMark + 1]].
			^ #()].
	vars := OrderedCollection new.
	[hereType == #word]
		whileTrue: [vars addLast: (encoder bindTemp: self advance)].
	(self match: #verticalBar) ifTrue: 
		[tempsMark := prevMark.
		^ vars].
	^ self expected: 'Vertical bar'
! !
!Parser methodsFor: 'expression types' stamp: 'cwp 12/27/2012 10:14' prior: 34180638!
temporariesIn: methodSelector
	" [ '|' (variable)* '|' ]"
	| vars theActualText |
	(self match: #verticalBar) ifFalse: 
		["no temps"
		doitFlag ifTrue:
			[tempsMark := self interactive
								ifTrue: [cue requestor selectionInterval first]
								ifFalse: [1].
			^ #()].
		tempsMark := hereMark	"formerly --> prevMark + prevToken".
		tempsMark > 0 ifTrue:
			[theActualText := source contents.
			[tempsMark < theActualText size and: [(theActualText at: tempsMark) isSeparator]]
				whileTrue: [tempsMark := tempsMark + 1]].
			^ #()].
	vars := OrderedCollection new.
	[hereType == #word]
		whileTrue: [vars addLast: (encoder bindTemp: self advance in: methodSelector)].
	(self match: #verticalBar) ifTrue: 
		[tempsMark := prevMark.
		^ vars].
	^ self expected: 'Vertical bar'! !
!Compiler methodsFor: 'public access' stamp: 'cwp 12/27/2012 10:11' prior: 53971863!
compiledMethodFor: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock logged: logFlag
	"Compiles the sourceStream into a parse tree, then generates code
	 into a method, and answers it.  If receiver is not nil, then the text can
	 refer to instance variables of that receiver (the Inspector uses this).
	 If aContext is not nil, the text can refer to temporaries in that context
	 (the Debugger uses this). If aRequestor is not nil, then it will receive a 
	 notify:at: message before the attempt to evaluate is aborted."

	| methodNode method theClass |
	theClass := (aContext == nil ifTrue: [receiver] ifFalse: [aContext receiver]) class.
	self from: textOrStream class: theClass context: aContext notifying: aRequestor.
	methodNode := self translate: sourceStream noPattern: true ifFail: [^failBlock value].
	method := self interactive ifTrue: [ 	methodNode generateWithTempNames ] 
		ifFalse: [methodNode generate].
		
	logFlag ifTrue:
		[SystemChangeNotifier uniqueInstance evaluated: sourceStream contents context: aContext].
	^method! !
!Compiler methodsFor: 'private' stamp: 'cwp 12/27/2012 11:33' prior: 34363593!
format: aStream noPattern: noPattern ifFail: failBlock
	^(self parser
		parse: aStream
		cue: cue 
		noPattern: noPattern
		ifFail: [^failBlock value]) preen! !
!Compiler methodsFor: 'private' stamp: 'cwp 12/27/2012 10:08' prior: 58306325!
interactive
	"Answer true if compilation is interactive"

	^ cue requestor notNil! !
!Compiler methodsFor: 'error handling' stamp: 'cwp 12/27/2012 10:10' prior: 50779387!
notify: aString at: location
	"Refer to the comment in Object|notify:."

	^ cue requestor == nil
		ifTrue: [SyntaxErrorNotification
					inClass: cue getClass
					category: cue category
					withCode: 
						(sourceStream contents
							copyReplaceFrom: location
							to: location - 1
							with: aString)
					doitFlag: false
					errorMessage: aString
					location: location]
		ifFalse: [cue requestor
					notify: aString
					at: location
					in: sourceStream]! !
!Compiler methodsFor: 'public access' stamp: 'cwp 12/27/2012 11:34' prior: 50777201!
parse: textOrStream in: aClass notifying: req
	"Compile the argument, textOrStream, with respect to the class, aClass, and
	 answer the MethodNode that is the root of the resulting parse tree.  Notify the
	 argument, req, if an error occurs. The failBlock is defaulted to an empty block."

	self from: textOrStream class: aClass context: nil notifying: req.
	^self parser
		parse: sourceStream
		cue: cue
		noPattern: false
		ifFail: []! !
!Compiler methodsFor: 'public access' stamp: 'cwp 12/27/2012 10:09' prior: 36332471!
parser

	parser ifNil: [parser := (cue getClass ifNil: [self class]) newParser].
	^parser! !
!Compiler methodsFor: 'private' stamp: 'cwp 12/27/2012 11:37' prior: 50780779!
translate: aStream noPattern: noPattern ifFail: failBlock
	^self parser
		parse: aStream
		cue: cue 
		noPattern: noPattern
		ifFail: [^failBlock value]! !
!Compiler methodsFor: 'public access' stamp: 'cwp 12/27/2012 11:37' prior: 19124095!
translate: aStream noPattern: noPattern ifFail: failBlock parser: parser
	| tree |
	tree := parser
			parse: aStream
			cue: cue 
			noPattern: noPattern
			ifFail: [^ failBlock value].
	^ tree! !
!Encoder methodsFor: 'results' stamp: 'cwp 12/27/2012 10:26' prior: 50999892!
associationForClass
	| assoc |
	assoc := self environment associationAt: cue getClass name ifAbsent: [nil].
	^assoc value == cue getClass
		ifTrue: [assoc]
		ifFalse: [Association new value: cue getClass]! !
!Encoder methodsFor: 'temps' stamp: 'cwp 12/27/2012 10:25' prior: 20148386!
bindTemp: name in: methodSelector
	"Declare a temporary; error not if a field or class variable."
	scopeTable at: name ifPresent:[:node|
		"When non-interactive raise the error only if its a duplicate"
		(node isTemp or:[requestor interactive])
			ifTrue:[^self notify:'Name is already defined']
			ifFalse:[Transcript 
				show: '(', name, ' is shadowed in "' , cue getClass printString , '>>' , methodSelector printString , '")']].
	^self reallyBind: name! !
!Encoder methodsFor: 'private' stamp: 'cwp 12/27/2012 10:25' prior: 20149084!
classEncoding
	"This is a hack so that the parser may findout what class it was parsing for when it wants to create a syntax error view."
	^ cue getClass! !
!Encoder methodsFor: 'encoding' stamp: 'cwp 12/27/2012 11:39' prior: 20138819!
encodeLiteral: object

	^self
		name: object
		key: (cue  literalScannedAs: object notifying: self)
		class: LiteralNode
		type: LdLitType
		set: litSet! !
!Encoder methodsFor: 'encoding' stamp: 'cwp 12/27/2012 11:40' prior: 20139010!
encodeSelector: aSelector

	^self
		name: aSelector
		key: aSelector
		class: SelectorNode
		type: SendType
		set: selectorSet! !
!Encoder methodsFor: 'encoding' stamp: 'cwp 12/27/2012 11:40' prior: 58545123!
environment
	"Answer the environment of the current compilation context,
	 be it in a class or global (e.g. a workspace)"
	^cue environment! !
!Encoder methodsFor: 'private' stamp: 'cwp 12/27/2012 11:41' prior: 50994497!
lookupInPools: varName ifFound: assocBlock

	^Symbol
		hasInterned: varName
		ifTrue:
			[:sym|
			(cue bindingOf: sym)
				ifNil: [^false]
				ifNotNil: [:assoc| assocBlock value: assoc]]! !
!Encoder methodsFor: 'private' stamp: 'cwp 12/27/2012 10:24' prior: 51004306!
possibleNamesFor: proposedName
	| results |
	results := cue getClass 
		possibleVariablesFor: proposedName 
		continuedFrom: nil.
	^ proposedName correctAgainst: nil continuedFrom: results.
! !
!Encoder methodsFor: 'private' stamp: 'cwp 12/27/2012 10:24' prior: 50995012!
possibleVariablesFor: proposedVariable

	| results |
	results := proposedVariable correctAgainstDictionary: scopeTable
								continuedFrom: nil.
	proposedVariable first canBeGlobalVarInitial ifTrue:
		[ results := cue getClass possibleVariablesFor: proposedVariable
						continuedFrom: results ].
	^ proposedVariable correctAgainst: nil continuedFrom: results.
! !
!Encoder methodsFor: 'encoding' stamp: 'cwp 12/27/2012 11:42' prior: 51002830!
undeclared: name
	| sym |
	requestor interactive ifTrue:
		[requestor requestor == #error: ifTrue:
			[requestor error: 'Undeclared'].
		 ^self notify: 'Undeclared'].
	"Allow knowlegeable clients to squash the undeclared warning if they want (e.g.
	 Diffing pretty printers that are simply formatting text).  As this breaks
	 compilation it should only be used by clients that want to discard the result
	 of the compilation.  To squash the warning use e.g.
		[Compiler format: code in: class notifying: nil decorated: false]
			on: UndeclaredVariableWarning
			do: [:ex| ex resume: false]"
	sym := name asSymbol.
	^(UndeclaredVariableWarning new name: name selector: selector class: cue getClass) signal
		ifTrue:
			[| undeclared |
			undeclared := cue environment undeclared.
			undeclared at: sym put: nil.
			self global: (undeclared associationAt: sym) name: sym]
		ifFalse:
			[self global: (Association key: sym) name: sym]! !
!Encoder methodsFor: 'private' stamp: 'cwp 12/27/2012 10:23' prior: 51006007!
warnAboutShadowed: name
	requestor addWarning: name,' is shadowed'.
	selector ifNotNil:
		[Transcript cr; show: cue getClass name,'>>', selector, '(', name,' is shadowed)']! !

"Compiler"!
!SmalltalkImage methodsFor: 'housekeeping' stamp: 'cwp 6/22/2012 15:56' prior: 58497062!
cleanOutUndeclared 
	globals undeclared removeUnreferencedKeys! !
!SmalltalkImage methodsFor: 'special objects' stamp: 'cwp 6/22/2012 09:01' prior: 40515090!
recreateSpecialObjectsArray
	"Smalltalk recreateSpecialObjectsArray"
	
	"To external package developers:
	**** DO NOT OVERRIDE THIS METHOD.  *****
	If you are writing a plugin and need additional special object(s) for your own use, 
	use addGCRoot() function and use own, separate special objects registry "
	
	"The Special Objects Array is an array of objects used by the Squeak virtual machine.
	 Its contents are critical and accesses to it by the VM are unchecked, so don't even
	 think of playing here unless you know what you are doing."
	| newArray |
	newArray := Array new: 56.
	"Nil false and true get used throughout the interpreter"
	newArray at: 1 put: nil.
	newArray at: 2 put: false.
	newArray at: 3 put: true.
	"This association holds the active process (a ProcessScheduler)"
	newArray at: 4 put: (self bindingOf: #Processor).
	"Numerous classes below used for type checking and instantiation"
	newArray at: 5 put: Bitmap.
	newArray at: 6 put: SmallInteger.
	newArray at: 7 put: ByteString.
	newArray at: 8 put: Array.
	newArray at: 9 put: Smalltalk.
	newArray at: 10 put: Float.
	newArray at: 11 put: MethodContext.
	newArray at: 12 put: BlockContext.
	newArray at: 13 put: Point.
	newArray at: 14 put: LargePositiveInteger.
	newArray at: 15 put: Display.
	newArray at: 16 put: Message.
	newArray at: 17 put: CompiledMethod.
	newArray at: 18 put: (self specialObjectsArray at: 18).
	"(low space Semaphore)"
	newArray at: 19 put: Semaphore.
	newArray at: 20 put: Character.
	newArray at: 21 put: #doesNotUnderstand:.
	newArray at: 22 put: #cannotReturn:.
	newArray at: 23 put: nil. "This is the process signalling low space."
	"An array of the 32 selectors that are compiled as special bytecodes,
	 paired alternately with the number of arguments each takes."
	newArray at: 24 put: #(	#+ 1 #- 1 #< 1 #> 1 #<= 1 #>= 1 #= 1 #~= 1
							#* 1 #/ 1 #\\ 1 #@ 1 #bitShift: 1 #// 1 #bitAnd: 1 #bitOr: 1
							#at: 1 #at:put: 2 #size 0 #next 0 #nextPut: 1 #atEnd 0 #== 1 #class 0
							#blockCopy: 1 #value 0 #value: 1 #do: 1 #new 0 #new: 1 #x 0 #y 0 ).
	"An array of the 255 Characters in ascii order.
	 Cog inlines table into machine code at: prim so do not regenerate it."
	newArray at: 25 put: (self specialObjectsArray at: 25).
	newArray at: 26 put: #mustBeBoolean.
	newArray at: 27 put: ByteArray.
	newArray at: 28 put: Process.
	"An array of up to 31 classes whose instances will have compact headers"
	newArray at: 29 put: self compactClassesArray.
	newArray at: 30 put: (self specialObjectsArray at: 30). "(delay Semaphore)"
	newArray at: 31 put: (self specialObjectsArray at: 31). "(user interrupt Semaphore)"
	"Entries 32 - 34 unreferenced. Previously these contained prototype instances to be copied for fast initialization"
	newArray at: 32 put: nil. "was (Float new: 2)"
	newArray at: 33 put: nil. "was (LargePositiveInteger new: 4)"
	newArray at: 34 put: nil. "was Point new"
	newArray at: 35 put: #cannotInterpret:.
	"Note: This must be fixed once we start using context prototypes (yeah, right)"
	"(MethodContext new: CompiledMethod fullFrameSize)."
	newArray at: 36 put: (self specialObjectsArray at: 36). "Is the prototype MethodContext (unused by the VM)"
	newArray at: 37 put: BlockClosure.
	"(BlockContext new: CompiledMethod fullFrameSize)."
	newArray at: 38 put: (self specialObjectsArray at: 38). "Is the prototype BlockContext (unused by the VM)"
	"array of objects referred to by external code"
	newArray at: 39 put: (self specialObjectsArray at: 39).	"preserve external semaphores"
	newArray at: 40 put: nil. "Reserved for Mutex in Cog VMs"
	newArray at: 41 put: nil. "Reserved for a LinkedList instance for overlapped calls in CogMT"
	"finalization Semaphore"
	newArray at: 42 put: ((self specialObjectsArray at: 42) ifNil: [Semaphore new]).
	newArray at: 43 put: LargeNegativeInteger.
	"External objects for callout.
	 Note: Written so that one can actually completely remove the FFI."
	newArray at: 44 put: (self at: #ExternalAddress ifAbsent: []).
	newArray at: 45 put: (self at: #ExternalStructure ifAbsent: []).
	newArray at: 46 put: (self at: #ExternalData ifAbsent: []).
	newArray at: 47 put: (self at: #ExternalFunction ifAbsent: []).
	newArray at: 48 put: (self at: #ExternalLibrary ifAbsent: []).
	newArray at: 49 put: #aboutToReturn:through:.
	newArray at: 50 put: #run:with:in:.
	"51 reserved for immutability message"
	"newArray at: 51 put: #attemptToAssign:withIndex:."
	newArray at: 52 put: #(nil "nil => generic error" #'bad receiver'
							#'bad argument' #'bad index'
							#'bad number of arguments'
							#'inappropriate operation'  #'unsupported operation'
							#'no modification' #'insufficient object memory'
							#'insufficient C memory' #'not found' #'bad method'
							#'internal error in named primitive machinery'
							#'object may move').
	"53 to 55 are for Alien"
	newArray at: 53 put: (self at: #Alien ifAbsent: []).
	newArray at: 54 put: #invokeCallback:stack:registers:jmpbuf:.
	newArray at: 55 put: (self at: #UnsafeAlien ifAbsent: []).

	"Weak reference finalization"
	newArray at: 56 put: (self at: #WeakFinalizationList ifAbsent: []).

	"Now replace the interpreter's reference in one atomic operation"
	self specialObjectsArray becomeForward: newArray
	! !
!SmalltalkImage methodsFor: 'shrinking' stamp: 'cwp 6/22/2012 15:57' prior: 37288071!
unloadAllKnownPackages
	"Unload all packages we know how to unload and reload"

	"Prepare unloading"
	Smalltalk zapMVCprojects.
	Flaps disableGlobalFlaps: false.
	StandardScriptingSystem removeUnreferencedPlayers.
	Project removeAllButCurrent.
	#('Morphic-UserObjects' 'EToy-UserObjects' 'Morphic-Imported' )
		do: [:each | SystemOrganization removeSystemCategory: each].
	Smalltalk at: #ServiceRegistry ifPresent:[:aClass|
		SystemChangeNotifier uniqueInstance
			noMoreNotificationsFor: aClass.
	].
	World removeAllMorphs.

	"Go unloading"
	#(	'ReleaseBuilder' 'ScriptLoader'
		'311Deprecated' '39Deprecated'
		'Universes' 'SMLoader' 'SMBase' 'Installer-Core'
		'VersionNumberTests' 'VersionNumber'
		'Services-Base' 'PreferenceBrowser' 'Nebraska'
		'ToolBuilder-MVC' 'ST80'
		'CollectionsTests' 'GraphicsTests' 'KernelTests'  'MorphicTests' 
		'MultilingualTests' 'NetworkTests' 'ToolsTests' 'TraitsTests'
		'SystemChangeNotification-Tests' 'FlexibleVocabularies' 
		'EToys' 'Protocols' 'XML-Parser' 'Tests' 'SUnitGUI'
		'Help-Squeak' 'HelpSystem' 'SystemReporter'
	) do: [:pkgName| 
			(MCPackage named: pkgName) unload.
			MCMcmUpdater disableUpdatesOfPackage: pkgName.
			].
	"Traits use custom unload"
	Smalltalk at: #Trait ifPresent:[:aClass| aClass unloadTraits].

	"Post-unload cleanup"
	MCWorkingCopy flushObsoletePackageInfos.
	SystemOrganization removeSystemCategory: 'UserObjects'.
	Presenter defaultPresenterClass: nil.
	World dumpPresenter.
	ScheduledControllers := nil.
	Preferences removePreference: #allowEtoyUserCustomEvents.
	SystemOrganization removeEmptyCategories.
	ChangeSet removeChangeSetsNamedSuchThat:[:cs | (cs == ChangeSet current) not].
	globals undeclared removeUnreferencedKeys.
	StandardScriptingSystem initialize.
	MCFileBasedRepository flushAllCaches.
	MCDefinition clearInstances.
	Behavior flushObsoleteSubclasses.
	ChangeSet current clear.
	ChangeSet current name: 'Unnamed1'.
	Smalltalk flushClassNameCache.
	Smalltalk at: #Browser ifPresent:[:br| br initialize].
	DebuggerMethodMap voidMapCache.
	DataStream initialize.
	AppRegistry removeObsolete.
	FileServices removeObsolete.
	Preferences removeObsolete.
	TheWorldMenu removeObsolete.
	Smalltalk garbageCollect.
	Symbol compactSymbolTable.
	TheWorldMainDockingBar updateInstances.
	MorphicProject defaultFill: (Color gray: 0.9).
	World color: (Color gray: 0.9).
! !
!InternalTranslator methodsFor: 'fileIn/fileOut' stamp: 'cwp 6/20/2012 17:34' prior: 40472775!
scanFrom: aStream 
	^ self scanFrom: aStream environment: Environment default! !
!NaturalLanguageTranslator methodsFor: 'fileIn/fileOut' stamp: 'cwp 6/20/2012 17:27' prior: 40496770!
scanFrom: aStream 
	^ self scanFrom: aStream environment: Environment default! !
!SystemDictionary methodsFor: 'dictionary access' stamp: 'cwp 6/22/2012 15:58' prior: 30574136!
at: aKey put: anObject 
	"Override from Dictionary to check Undeclared and fix up
	references to undeclared variables."
	| index element |
	(self includesKey: aKey) ifFalse: 
		[self declare: aKey from: (self at: #Undeclared).
		self flushClassNameCache].
	super at: aKey put: anObject.
	^ anObject! !

"System"!

CodeHolder subclass: #Browser
	instanceVariableNames: 'environment systemOrganizer classOrganizer metaClassOrganizer editSelection metaClassIndicated selectedSystemCategory selectedClassName selectedMessageName selectedMessageCategoryName'
	classVariableNames: 'ListClassesHierarchically RecentClasses'
	poolDictionaries: ''
	category: 'Tools-Browser'!
!Browser commentStamp: 'cwp 12/27/2012 11:09' prior: 36419432!
I represent a query path into the class descriptions, the software of the system.!
!Browser methodsFor: 'accessing' stamp: 'cwp 6/24/2012 23:20'!
selectEnvironment: anEnvironment 
	environment := anEnvironment.
	systemOrganizer := environment organization! !
!Browser methodsFor: 'system category list' stamp: 'cwp 6/24/2012 23:06' prior: 36467357!


More information about the pypy-commit mailing list