Author: eliot Date: 2010-09-04 08:52:10 -0700 (Sat, 04 Sep 2010) New Revision: 2275

Modified: branches/Cog/image/VMMaker-Squeak4.1.changes branches/Cog/image/VMMaker-Squeak4.1.image branches/Cog/macbuild/CoreVM.plist Log: Fix filename character encoding for Mac OS X (in Info.plist; use UTF-8). Update minimal VMMaker image to latest trunk.

Modified: branches/Cog/image/VMMaker-Squeak4.1.changes =================================================================== --- branches/Cog/image/VMMaker-Squeak4.1.changes 2010-09-03 00:40:30 UTC (rev 2274) +++ branches/Cog/image/VMMaker-Squeak4.1.changes 2010-09-04 15:52:10 UTC (rev 2275) @@ -124548,4 +124548,3993 @@

MCFileBasedRepository flushAllCaches!

-----QUIT----{9 August 2010 . 9:54:57 pm} VMMaker-Squeak4.1.image priorSource: 5021172! \ No newline at end of file +----QUIT----{9 August 2010 . 9:54:57 pm} VMMaker-Squeak4.1.image priorSource: 5021172! +!MCMcmUpdater commentStamp: 'dtl 5/10/2010 23:22' prior: 36522691! +MCMcmUpdater provides utility methods for updating Monticello packages from Monticello configurations. + +When Monticello configurations are stored in a repository, MCMcmUpdater acts as an update stream. It first ensures that each configuration map has been loaded in sequence, then updates the last configuration map to the most recent version for each specified package, and finally loads these versions to produce a fully updated configuration. ! + +----STARTUP----{24 August 2010 . 8:55:24 pm} as /Users/eliot/Cog/oscog/Cog.squeakvm.org/image/VMMaker-Squeak4.1.image! + +!MCMcmUpdater class methodsFor: 'updating' stamp: 'ar 8/24/2010 20:04' prior: 57254025! +updateFromRepositories: repositoryUrls + "MCMcmUpdater updateFromRepositories: #( + 'http://squeaksource.com/MCUpdateTest' + )" + + | repos config | + Preferences enable: #upgradeIsMerge. + LastUpdateMap ifNil:[LastUpdateMap := Dictionary new]. + "The list of repositories to consult in order" + repos := repositoryUrls collect:[:url| + MCRepositoryGroup default repositories + detect:[:r| r description = url] + ifNone:[ | r | + r := MCHttpRepository location: url user: '' password: ''. + MCRepositoryGroup default addRepository: r. + r]]. + + "The list of updates-author.version.mcm sorted by version" + repos do:[:r| r cacheAllFileNamesDuring:[ + | minVersion updateList allNames | + updateList := SortedCollection new. + minVersion := LastUpdateMap at: r description ifAbsent:[0]. + "Find all the updates-author.version.mcm files" + 'Checking ', r description + displayProgressAt: Sensor cursorPoint + from: 0 to: 1 during:[:bar| + bar value: 0. + allNames := r allFileNames. + ]. + allNames do:[:versionedName| | version base parts author type | + parts := versionedName findTokens: '.-'. + parts size = 4 ifTrue:[ + base := parts at: 1. + author := parts at: 2. + version := [(parts at: 3) asNumber] on: Error do:[:ex| ex return: 0]. + type := parts at: 4. + ]. + (base = 'update' and:[version >= minVersion and:[type = 'mcm']]) + ifTrue:[updateList add: version -> versionedName]]. + + "Proceed only if there are updates available at all." + updateList ifNotEmpty: [ + "Now process each update file. Check if we have all dependencies and if not, + load the entire configuration (this is mostly to skip older updates quickly)" + updateList do:[:assoc| + ProgressNotification signal: '' extra: 'Processing ', assoc value. + config := r versionFromFileNamed: assoc value. + self updateMissingPackages ifFalse:[ + "Skip packages that are not in the image" + config dependencies: (config dependencies + select:[:dep| dep package hasWorkingCopy])]. + (config dependencies allSatisfy:[:dep| dep isFulfilled]) + ifFalse:[config upgrade]. + LastUpdateMap at: r description put: assoc key. + ] displayingProgress: 'Processing configurations'. + "We've loaded all the provided update configurations. + Use the latest configuration to update all the remaining packages." + config updateFromRepositories. + config upgrade. + ]]. + ]. + ^config! ! +!MCMcmUpdater class methodsFor: 'updating' stamp: 'ar 8/24/2010 20:03'! +updateMissingPackages + "Whether to update missing (unloaded) packages" + + <preference: 'Update missing package' + category: 'Monticello' + description: 'If true, missing (unloaded) packages will be loaded during the update process.' + type: #Boolean> + + ^UpdateMissingPackages ifNil:[true]! ! +!MCMcmUpdater class methodsFor: 'updating' stamp: 'ar 8/24/2010 20:04'! +updateMissingPackages: aBool + "Whether to update missing (unloaded) packages" + + UpdateMissingPackages := aBool.! ! + +"MonticelloConfigurations"! + +UpdateMissingPackages! + +UpdateMissingPackages := false! +!Heap methodsFor: 'enumerating' stamp: 'nice 8/21/2010 15:40'! +collect: aBlock + ^self collect: aBlock as: Array! ! +!Heap methodsFor: 'copying' stamp: 'nice 8/21/2010 15:53'! +copyEmpty + "Answer a copy of the receiver without any of the receiver's elements." + + ^self class sortBlock: sortBlock! ! +!Heap methodsFor: 'enumerating' stamp: 'nice 8/21/2010 15:49'! +select: aBlock + "Evaluate aBlock with each of my elements as the argument. Collect into + a new collection like the receiver, only those elements for which aBlock + evaluates to true." + + | newCollection | + newCollection := self copyEmpty. + self do: + [:each | + (aBlock value: each) + ifTrue: [newCollection add: each]]. + ^ newCollection! ! + +Heap removeSelector: #species! +!ZipArchiveTests methodsFor: 'tests' stamp: 'ar 8/11/2010 20:45'! +testDate29Feb2000 + "Ensure that dates with leap years don't screw up in the conversion" + + | archive mbr theDate | + theDate := Date year: 2000 month: 2 day: 29. + archive := ZipArchive new. + mbr := archive addDeflateString:'foo' as: 'bar'. + mbr setLastModFileDateTimeFrom: theDate asSeconds. + self shouldnt:[mbr lastModTime] raise: Error. + self assert: (Date fromSeconds: mbr lastModTime) = theDate.! ! +!ZipArchiveMember methodsFor: 'private' stamp: 'jdr 8/11/2010 10:39'! +dosToSqueakTime: dt + "DOS years start at 1980, so add 1980." + | year mon mday hour min sec date time | + + year := (( dt bitShift: -25 ) bitAnd: 16r7F ). + mon := (( dt bitShift: -21 ) bitAnd: 16r0F ). + mday := (( dt bitShift: -16 ) bitAnd: 16r1F ). + date := Date newDay: mday month: mon year: year+1980. + + hour := (( dt bitShift: -11 ) bitAnd: 16r1F ). + min := (( dt bitShift: -5 ) bitAnd: 16r3F ). + sec := (( dt bitShift: 1 ) bitAnd: 16r3E ). + time := ((( hour * 60 ) + min ) * 60 ) + sec. + + ^date asSeconds + time + + ! ! +!ZipArchiveMember methodsFor: 'accessing' stamp: 'jdr 8/11/2010 10:38' prior: 33416759! +lastModTime + "Return my last modification date/time stamp, + converted to Squeak seconds" + + ^self dosToSqueakTime: lastModFileDateTime! ! +!ZipArchiveMember methodsFor: 'accessing' stamp: 'jdr 8/11/2010 11:08' prior: 33417394! +setLastModFileDateTimeFrom: aSmalltalkTime + + lastModFileDateTime := self squeakToDosTime: aSmalltalkTime! ! +!ZipArchiveMember methodsFor: 'private' stamp: 'jdr 8/11/2010 11:00'! +squeakToDosTime: secs + | dosTime dateTime | + + dateTime := Time dateAndTimeFromSeconds: secs. + dosTime := (dateTime second seconds) bitShift: -1. + dosTime := dosTime + ((dateTime second minutes) bitShift: 5). + dosTime := dosTime + ((dateTime second hours) bitShift: 11). + dosTime := dosTime + ((dateTime first dayOfMonth) bitShift: 16). + dosTime := dosTime + ((dateTime first monthIndex) bitShift: 21). + dosTime := dosTime + (((dateTime first year) - 1980) bitShift: 25). + ^dosTime +! ! +!ZipArchiveMember methodsFor: 'private-writing' stamp: 'ar 8/10/2010 13:15' prior: 33431506! +writeDataTo: aStream + "Copy my (possibly inflated or deflated) data to the given stream. + This might do compression, decompression, or straight copying, depending + on the values of compressionMethod and desiredCompressionMethod" + + "Note: Do not shortcut this method if uncompressedSize = 0. Even in this case + data may be produced by the compressor (i.e., '' zipped size > 0) and must + be stored in the file or else other utilities will treat the zip file as corrupt." + + (compressionMethod = CompressionStored and: [ desiredCompressionMethod = CompressionDeflated ]) + ifTrue: [ ^self compressDataTo: aStream ]. + + (compressionMethod = CompressionDeflated and: [ desiredCompressionMethod = CompressionStored ]) + ifTrue: [ ^self uncompressDataTo: aStream ]. + + self copyDataTo: aStream.! ! + +ZipArchiveMember removeSelector: #unixToSqueakTime:! + +ZipArchiveMember removeSelector: #unixToDosTime:! + +ZipArchiveMember removeSelector: #dosToUnixTime:! + +"Compression"! +!WeakMessageSend methodsFor: 'converting' stamp: 'jmv 5/13/2009 10:19' prior: 33145124! +asMinimalRepresentation + + ^self isReceiverOrAnyArgumentGarbage + ifTrue: [ nil ] + ifFalse: [ self ]! ! +!WeakMessageSend methodsFor: 'evaluating' stamp: 'jmv 5/14/2009 10:21' prior: 33145298! +value + ^self valueOtherwise: []! ! +!WeakMessageSend methodsFor: 'evaluating' stamp: 'nice 8/22/2010 17:26'! +valueOtherwise: aBlock + ^ arguments + ifNil: [ + self withEnsuredReceiverDo: [ :r | r perform: selector ] otherwise: [ aBlock value ]] + ifNotNil: [ + self + withEnsuredReceiverAndArgumentsDo: [ :r :a | + r + perform: selector + withArguments: a ] + otherwise: [ aBlock value ]]! ! +!WeakMessageSend methodsFor: 'evaluating' stamp: 'jmv 5/14/2009 10:21' prior: 33145645! +valueWithArguments: anArray + ^ self valueWithArguments: anArray otherwise: []! ! +!WeakMessageSend methodsFor: 'evaluating' stamp: 'jmv 5/14/2009 10:12'! +valueWithArguments: anArray otherwise: aBlock + | argsToUse | + + "Safe to use, because they are built before ensureing receiver and args..." + argsToUse := self collectArguments: anArray. + ^ self + withEnsuredReceiverAndArgumentsDo: [ :r :a | + r + perform: selector + withArguments: argsToUse ] + otherwise: [ aBlock value ]! ! +!WeakMessageSend methodsFor: 'private' stamp: 'jmv 5/14/2009 10:03'! +withEnsuredReceiverAndArgumentsDo: aBlock otherwise: altBlock + "Grab real references to receiver and arguments. If they still exist, evaluate aBlock." + + "Return if my receiver has gone away" + | r a | + r := self receiver. + r ifNil: [ ^altBlock value ]. + + + "Make sure that my arguments haven't gone away" + a := Array withAll: arguments. + a with: shouldBeNil do: [ :arg :flag | + arg ifNil: [ flag ifFalse: [ ^altBlock value ]] + ]. + + ^aBlock value: r value: a! ! +!WeakMessageSend methodsFor: 'private' stamp: 'nice 8/22/2010 17:27'! +withEnsuredReceiverDo: aBlock otherwise: altBlock + "Grab a real reference to receive. If still there, evaluate aBlock. + Use altBlock if my receiver has gone away." + ^self receiver + ifNil: [ altBlock value ] + ifNotNil: [:r | aBlock value: r ]! ! +!WeakActionSequence methodsFor: 'converting' stamp: 'jmv 5/13/2009 10:20' prior: 33124129! +asMinimalRepresentation + + | valid | + valid := self reject: [:e | e isReceiverOrAnyArgumentGarbage ]. + valid size = 0 + ifTrue: [ ^nil ]. + valid size = 1 + ifTrue: [ ^valid first ]. + ^valid! ! +!WeakActionSequence methodsFor: 'evaluating' stamp: 'nice 8/22/2010 21:05' prior: 33124370! +value + "Answer the result of evaluating the elements of the receiver. + Actually, return just the last result." + + ^self inject: nil into: [ :previousAnswer :each | + each valueOtherwise: [ previousAnswer ]].! ! +!WeakActionSequence methodsFor: 'evaluating' stamp: 'nice 8/22/2010 21:02' prior: 33124666! +valueWithArguments: anArray + "Return the last result" + + ^self inject: nil into: [ :previousAnswer :each | + each valueWithArguments: anArray otherwise: [ previousAnswer ]]! ! +!Categorizer methodsFor: 'accessing' stamp: 'nice 8/19/2010 21:26' prior: 50571543! +sortCategories + | privateCategories publicCategories newCategories | + + privateCategories := self categories select: + [:one | (one findString: 'private' startingAt: 1 caseSensitive: false) = 1]. + publicCategories := self categories copyWithoutAll: privateCategories. + newCategories := publicCategories asArray sort , privateCategories asArray sort. + self categories: newCategories! ! +!BlockClosure methodsFor: 'evaluating' stamp: 'ul 8/2/2010 19:40' prior: 50398415! +ifError: errorHandlerBlock + "Evaluate the block represented by the receiver, and normally return it's value. If an error occurs, the errorHandlerBlock is evaluated, and it's value is instead returned. The errorHandlerBlock must accept zero, one, or two parameters (the error message and the receiver)." + "Examples: + [1 whatsUpDoc] ifError: [:err :rcvr | 'huh?']. + [1 / 0] ifError: [:err :rcvr | + 'ZeroDivide' = err + ifTrue: [Float infinity] + ifFalse: [self error: err]] +" + + ^ self on: Error do: [:ex | + errorHandlerBlock cull: ex description cull: ex receiver ]! ! +!BlockClosure methodsFor: 'exceptions' stamp: 'ul 8/12/2010 00:07' prior: 50404114! +onDNU: selector do: handleBlock + "Catch MessageNotUnderstood exceptions but only those of the given selector (DNU stands for doesNotUnderstand:)" + + ^ self on: MessageNotUnderstood do: [:exception | + exception message selector = selector + ifTrue: [handleBlock cull: exception] + ifFalse: [exception pass] + ]! ! +!Time class methodsFor: 'clock' stamp: 'dtl 8/14/2010 15:25'! +primMicrosecondClock + "Answer the number of microseconds since the microsecond clock + was last reset or rolled over. Answer zero if the primitive fails." + + <primitive: 'primitiveMicrosecondClock'> + ^ 0! ! +!Time class methodsFor: 'clock' stamp: 'dtl 8/14/2010 14:53'! +primUtcWithOffset + "Answer an array with UTC microseconds since the Posix epoch and + the current seconds offset from GMT in the local time zone." + + <primitive: 'primitiveUtcWithOffset'> + ^ { 0 . 0 }! ! +!Object methodsFor: 'events-accessing' stamp: 'jmv 5/13/2009 10:14' prior: 24960894! +actionForEvent: anEventSelector + "Answer the action to be evaluated when <anEventSelector> has been triggered." + + ^self actionMap + at: anEventSelector asSymbol + ifAbsent: [nil]! ! +!Object methodsFor: 'events-accessing' stamp: 'nice 8/22/2010 20:57' prior: 24961232! +actionForEvent: anEventSelector +ifAbsent: anExceptionBlock + "Answer the action to be evaluated when <anEventSelector> has been triggered." + + | actions | + actions := self actionMap + at: anEventSelector asSymbol + ifAbsent: [nil]. + ^actions ifNil: [anExceptionBlock value]! ! +!Object methodsFor: 'events-accessing' stamp: 'jmv 5/13/2009 10:16' prior: 24962452! +setActionSequence: actionSequence +forEvent: anEventSelector + + | action | + "This is a good time to compact the action sequence of old, garbage collected stuff." + action := actionSequence asMinimalRepresentation. + action + ifNil: [ self removeActionsForEvent: anEventSelector] + ifNotNil: [ + self updateableActionMap + at: anEventSelector asSymbol + put: action]! ! +!InstructionStream methodsFor: 'scanning' stamp: 'eem 8/13/2010 11:45'! +followingBytecode + "Answer the bytecode of the following bytecode (different to nextByte)." + + ^self method at: self followingPc! ! +!InstructionStream methodsFor: 'scanning' stamp: 'eem 8/13/2010 11:45'! +followingPc + "Answer the pc of the following bytecode." + + ^self nextPc: (self method at: pc)! ! +!InstructionStream methodsFor: 'private' stamp: 'eem 8/13/2010 11:38'! +nextPc: currentByte + "Answer the pc of the next bytecode following the current one, given the current bytecode.." + + | type | + type := currentByte // 16. + ^type = 8 "extensions" + ifTrue: [pc + (#(2 2 2 2 3 2 2 1 1 1 2 1 3 3 3 4) at: currentByte \ 16 + 1)] + ifFalse: [type = 10 "long jumps" + ifTrue: [pc + 2] + ifFalse: [pc + 1]]! ! +!InstructionStream methodsFor: 'scanning' stamp: 'eem 8/13/2010 11:43' prior: 51439508! +scanFor: scanBlock + "Answer the index of the first bytecode for which scanBlock + answers true when supplied with that bytecode." + + | method end byte | + method := self method. + end := method endPC. + [pc <= end] whileTrue: + [(scanBlock value: (byte := method at: pc)) ifTrue: + [^true]. + pc := self nextPc: byte]. + ^false! ! +!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'nice 8/19/2010 16:32' prior: 54720589! +allMethodCategoriesIntegratedThrough: mostGenericClass + "Answer a list of all the method categories of the receiver and all its superclasses, up through mostGenericClass" + + | aColl | + aColl := OrderedCollection new. + self withAllSuperclasses do: + [:aClass | + (aClass includesBehavior: mostGenericClass) + ifTrue: [aColl addAll: aClass organization categories]]. + aColl remove: 'no messages' asSymbol ifAbsent: []. + + ^aColl asSet asArray sort: [:a :b | a asLowercase < b asLowercase] + +"ColorTileMorph allMethodCategoriesIntegratedThrough: TileMorph"! ! +!ContextPart methodsFor: 'private-exceptions' stamp: 'ul 8/2/2010 19:37' prior: 50811097! +handleSignal: exception + "Sent to handler (on:do:) contexts only. If my exception class (first arg) handles exception then execute my handle block (second arg), otherwise forward this message to the next handler context. If none left, execute exception's defaultAction (see nil>>handleSignal:)." + + | val | + (((self tempAt: 1) handles: exception) and: [self tempAt: 3]) ifFalse: [ + ^ self nextHandlerContext handleSignal: exception]. + + exception privHandlerContext: self contextTag. + self tempAt: 3 put: false. "disable self while executing handle block" + val := [(self tempAt: 2) valueWithPossibleArgument: exception ] + ensure: [self tempAt: 3 put: true]. + self return: val. "return from self if not otherwise directed in handle block" +! ! +!MessageSend methodsFor: 'private' stamp: 'jmv 5/14/2009 09:54'! +isReceiverOrAnyArgumentGarbage + ^false! ! +!MessageSend methodsFor: 'evaluating' stamp: 'jmv 5/14/2009 10:11'! +valueOtherwise: aBlock + "Send the message and answer the return value" + + ^self value! ! +!MessageSend methodsFor: 'evaluating' stamp: 'jmv 5/14/2009 10:22'! +valueWithArguments: anArray otherwise: aBlock + + ^ self valueWithArguments: anArray! ! +!CompiledMethod methodsFor: 'decompiling' stamp: 'eem 8/12/2010 13:52' prior: 19056689! +decompileWithTemps + "Return the decompiled parse tree that represents self, but get the temp names + by compiling the sourcecode..." + + | class selector | + class := self methodClass ifNil: [Object]. + selector := self selector ifNil: [self defaultSelector]. + + (self fileIndex > 0 and: [(SourceFiles at: self fileIndex) isNil]) ifTrue: [ + "Emergency or no source file -- decompile without temp names " + ^self decompile. + ]. + ^((self decompilerClass new withTempNames: self methodNode schematicTempNamesString) + decompile: selector + in: class + method: self)! ! +!Float methodsFor: 'arithmetic' stamp: 'nice 8/21/2010 22:31' prior: 20878637! +abs + "This is faster than using Number abs and works for negativeZero." + self <= 0.0 + ifTrue: [^ 0.0 - self] + ifFalse: [^ self]! ! +!ProtoObject methodsFor: 'testing' stamp: 'ul 8/12/2010 00:04' prior: 52246958! +ifNil: nilBlock ifNotNil: ifNotNilBlock + "Evaluate the block, unless I'm == nil (q.v.)" + + ^ ifNotNilBlock cull: self! ! +!ProtoObject methodsFor: 'testing' stamp: 'ul 8/12/2010 00:04' prior: 52247178! +ifNotNil: ifNotNilBlock + "Evaluate the block, unless I'm == nil (q.v.)" + + ^ ifNotNilBlock cull: self! ! +!ProtoObject methodsFor: 'testing' stamp: 'ul 8/12/2010 00:04' prior: 52246718! +ifNotNil: ifNotNilBlock ifNil: nilBlock + "If I got here, I am not nil, so evaluate the block ifNotNilBlock" + + ^ ifNotNilBlock cull: self! ! +!VariableScopeFinder commentStamp: 'eem 8/14/2010 19:45' prior: 0! +A VariableScopeFinder is used to find the minimum enclosing scope of a variable in a method. This is used when auto-declaring temporaries to find the smallest enclosing block in which to declare the temp. + +Instance Variables + theVariable: <VariableNode> + +theVariable + - the varable whose scope is to be determined +! +!BlockNode commentStamp: '<historical>' prior: 34152044! +I represent a bracketed block with 0 or more arguments and 1 or more statements. If I am initialized with no statements, I create one. I have a flag to tell whether my last statement returns a value from the enclosing method. My last three fields remember data needed for code generation. I can emit for value in the usual way, in which case I create a literal method (actually a context remotely copied) to be evaluated by sending it value: at run time. Or I can emit code to be evaluated in line; this only happens at the top level of a method and in conditionals and while-loops, none of which have arguments.! +!MessageNode commentStamp: '<historical>' prior: 59343427! +I represent a receiver and its message. + +Precedence codes: + 1 unary + 2 binary + 3 keyword + 4 other + +If special>0, I compile special code in-line instead of sending messages with literal methods as remotely copied contexts.! +!MethodNode commentStamp: 'eem 8/15/2010 10:49' prior: 59353244! +I am the root of the parse tree.. + +Instance Variables + arguments: <SequenceableCollection> + block: <BlockNode> + encoder: <BytecodeEncoder> + localsPool: <IdentitySet> + locationCounter: <Integer> + precedence: <Integer> + primitive: <Integer> + properties: <AdditionalMethodState|nil> + selectorOrFalse: <Object> + sourceText: <String|Text> + temporaries: <SequenceableCollection> + +arguments + - the collection of parsed or decompiled method arguments + +block + - the BlockNode holding the method's statements + +encoder + - the object that comprises the copiler's scope table, literal pool and back-end bytecode generator + +localsPool + - a set used to determine the set of copied values for each block in the method + +locationCounter + - an integer used to mark block scopes for the purposes of the closure transformation. See BlockNode>>#analyseArguments:temporaries:rootNode: + +precedence + - the precedence of the method's selector (see Symbol>>precedence) + +primitive + - if non-zero this is the integer code of the method's primitive + +properties + - the object used to accumulate method properties (a.k.a. pragmas) + +selectorOrFalse + - the method's selector or false if this is a doit + +sourceText + - the source test from which the method was compiled + +temporaries + - the collection of parsed or decompiled method temporaries +! +!ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 9/5/2009 20:08' prior: 52074955! +visitMessageNode: aMessageNode + aMessageNode receiver accept: self. + "receiver notNil ifTrue: ''receiver is nil for cascades'' + [receiver accept: self]." + aMessageNode selector accept: self. + aMessageNode argumentsInEvaluationOrder do: + [:argument| argument accept: self]! ! +!ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 8/13/2010 16:50'! +visitUndeclaredVariableNode: aVariableNode! ! +!VariableScopeFinder methodsFor: 'private' stamp: 'eem 8/12/2010 16:50'! +enclosingNodeFor: enumerator of: rootNode + "Answer the minimum enclosing root node for aVariabe or nil if none. + If the variable is accessed in more than one subnode then the rootNode is the + enclosing node, otherwise it is which ever single subnode node that includes it, if any. + enumerator applies its argument to all relevant subnodes of rootNode." + | enclosingNodeOrNil | + enclosingNodeOrNil := nil. + enumerator value: + [:subnode| + (subnode accept: self) ifNotNil: + [:enclosingNode| + enclosingNodeOrNil := enclosingNodeOrNil + ifNil: [enclosingNode] + ifNotNil: [rootNode]]]. + ^enclosingNodeOrNil! ! +!VariableScopeFinder methodsFor: 'initialize-release' stamp: 'eem 8/12/2010 16:18'! +ofVariable: aVariableNode + theVariable := aVariableNode! ! +!VariableScopeFinder methodsFor: 'visiting' stamp: 'eem 8/12/2010 16:51'! +visitAssignmentNode: anAssignmentNode + "Answer the minimum enclosing node for aVariabe or nil if none. + If the variable is accessed in more than one subexpression then anAssignmentNode + is the enclosing node, otherwise it is which ever single node that includes it, if any." + ^self + enclosingNodeFor: [:aBlock| + aBlock + value: anAssignmentNode value; + value: anAssignmentNode variable] + of: anAssignmentNode! ! +!VariableScopeFinder methodsFor: 'visiting' stamp: 'eem 8/12/2010 16:52'! +visitBlockNode: aBlockNode + "Answer the minimum enclosing node for aVariabe or nil if none. + If the variable is accessed in more than one statement then aBlockNode is the + enclosing node, otherwise it is which ever single block node that includes it, if any." + ^(self enclosingNodeFor: [:aBlock| aBlockNode statements do: aBlock] of: aBlockNode) ifNotNil: + [:aNode| + aNode isBlockNode ifTrue: [aNode] ifFalse: [aBlockNode]]! ! +!VariableScopeFinder methodsFor: 'visiting' stamp: 'eem 8/12/2010 16:52'! +visitBraceNode: aBraceNode + "Answer the minimum enclosing node for aVariabe or nil if none. + If the variable is accessed in more than one subexpression then aBraceNode + is the enclosing node, otherwise it is which ever single node that includes it, if any." + ^self + enclosingNodeFor: [:aBlock| aBraceNode elements do: aBlock] + of: aBraceNode! ! +!VariableScopeFinder methodsFor: 'visiting' stamp: 'eem 8/16/2010 18:02'! +visitCascadeNode: aCascadeNode + "Answer the minimum enclosing node for aVariabe or nil if none. + If the variable is accessed in more than one subexpression then aMessageNode is the + enclosing node, otherwise it is which ever single node that includes it, if any." + ^self + enclosingNodeFor: [:aBlock| + aBlock value: aCascadeNode receiver. + aCascadeNode messages do: + [:msg| msg argumentsInEvaluationOrder do: aBlock]] + of: aCascadeNode! ! +!VariableScopeFinder methodsFor: 'visiting' stamp: 'eem 8/12/2010 18:43'! +visitCommentNode: aNode + ^nil! ! +!VariableScopeFinder methodsFor: 'visiting' stamp: 'eem 8/12/2010 18:43'! +visitFieldNode: aNode + ^nil! ! +!VariableScopeFinder methodsFor: 'visiting' stamp: 'eem 8/12/2010 16:55'! +visitFutureNode: aFutureNode + ^aFutureNode receiver accept: self! ! +!VariableScopeFinder methodsFor: 'visiting' stamp: 'eem 8/12/2010 18:43'! +visitInstanceVariableNode: aNode + ^nil! ! +!VariableScopeFinder methodsFor: 'visiting' stamp: 'eem 8/12/2010 18:43'! +visitLiteralNode: aNode + ^nil! ! +!VariableScopeFinder methodsFor: 'visiting' stamp: 'eem 8/12/2010 19:03'! +visitLiteralVariableNode: aNode + ^nil! ! +!VariableScopeFinder methodsFor: 'visiting' stamp: 'eem 8/12/2010 17:07'! +visitMessageNode: aMessageNode + "Answer the minimum enclosing node for aVariabe or nil if none. + If the variable is accessed in more than one subexpression then aMessageNode is the + enclosing node, otherwise it is which ever single node that includes it, if any." + ^self + enclosingNodeFor: [:aBlock| + aBlock value: aMessageNode receiver. + aMessageNode argumentsInEvaluationOrder do: aBlock] + of: aMessageNode! ! +!VariableScopeFinder methodsFor: 'visiting' stamp: 'eem 8/12/2010 17:00'! +visitMethodNode: aMethodNode + ^aMethodNode block accept: self! ! +!VariableScopeFinder methodsFor: 'visiting' stamp: 'eem 8/12/2010 18:43'! +visitNewArrayNode: aNode + ^nil! ! +!VariableScopeFinder methodsFor: 'visiting' stamp: 'eem 8/12/2010 18:43'! +visitRemoteTempVectorNode: aNode + ^nil! ! +!VariableScopeFinder methodsFor: 'visiting' stamp: 'eem 8/12/2010 17:01'! +visitReturnNode: aReturnNode + ^aReturnNode expr accept: self! ! +!VariableScopeFinder methodsFor: 'visiting' stamp: 'eem 8/12/2010 18:43'! +visitSelectorNode: aNode + ^nil! ! +!VariableScopeFinder methodsFor: 'visiting' stamp: 'eem 8/12/2010 18:43'! +visitTempVariableNode: aNode + ^nil! ! +!VariableScopeFinder methodsFor: 'visiting' stamp: 'eem 8/13/2010 16:50'! +visitUndeclaredVariableNode: aVariableNode + ^theVariable name = aVariableNode name ifTrue: [theVariable]! ! +!VariableScopeFinder methodsFor: 'visiting' stamp: 'eem 8/12/2010 19:06'! +visitVariableNode: aVariableNode + ^nil! ! +!LeafNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 14:52' prior: 51552175! +emitCodeForEffect: stack encoder: encoder + + ^self! ! +!LeafNode methodsFor: 'code generation' stamp: 'eem 5/20/2008 15:25' prior: 51549757! +emitCodeForLoad: stack encoder: encoder + "Default is to do nothing. + Subclasses may need to override."! ! +!LeafNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 14:52' prior: 51552568! +sizeCodeForEffect: encoder + + ^0! ! +!LeafNode methodsFor: 'code generation' stamp: 'eem 5/20/2008 15:24' prior: 51550149! +sizeCodeForLoad: encoder + "Default is to do nothing. + Subclasses may need to override." + ^0! ! +!LeafNode methodsFor: 'code generation' stamp: 'eem 5/19/2008 15:10' prior: 51553184! +sizeCodeForValue: encoder + self subclassResponsibility! ! +!SelectorNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 14:52' prior: 52458608! +emitCode: stack args: nArgs encoder: encoder + + self emitCode: stack + args: nArgs + encoder: encoder + super: false! ! +!SelectorNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 17:47' prior: 52458959! +emitCode: stack args: nArgs encoder: encoder super: supered + stack pop: nArgs. + ^supered + ifTrue: + [encoder genSendSuper: index numArgs: nArgs] + ifFalse: + [encoder + genSend: (code < Send ifTrue: [code negated] ifFalse: [index]) + numArgs: nArgs]! ! +!SelectorNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 14:52' prior: 52461103! +emitCodeForEffect: stack encoder: encoder + + self shouldNotImplement! ! +!SelectorNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 14:52' prior: 52462600! +emitCodeForValue: stack encoder: encoder + + self shouldNotImplement! ! +!SelectorNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 16:15' prior: 52460344! +sizeCode: encoder args: nArgs super: supered + self reserve: encoder. + ^supered + ifTrue: + [code < Send "i.e. its a special selector" ifTrue: + [code := self code: (index := encoder sharableLitIndex: key) type: 5]. + encoder sizeSendSuper: index numArgs: nArgs] + ifFalse: + [self flag: #yuck. "special selector sends cause this problem" + encoder + sizeSend: (code < Send ifTrue: [code negated] ifFalse: [index]) + numArgs: nArgs]! ! +!SelectorNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 14:52' prior: 52462457! +sizeCodeForEffect: encoder + + self shouldNotImplement! ! +!SelectorNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 14:52' prior: 52458466! +sizeCodeForValue: encoder + + self shouldNotImplement! ! +!LiteralNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 16:19' prior: 51562326! +emitCodeForValue: stack encoder: encoder + stack push: 1. + (encoder + if: code + isSpecialLiteralForPush: + [:specialLiteral| + encoder genPushSpecialLiteral: specialLiteral]) + ifFalse: + [encoder genPushLiteral: index]! ! +!LiteralNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 17:03' prior: 51562996! +sizeCodeForValue: encoder + self reserve: encoder. + (encoder + if: code + isSpecialLiteralForPush: + [:specialLiteral| + ^encoder sizePushSpecialLiteral: specialLiteral]) + ifFalse: + [^encoder sizePushLiteral: index]! ! +!UndeclaredVariableNode methodsFor: 'visiting' stamp: 'eem 8/13/2010 16:51'! +accept: aVisitor + ^aVisitor visitUndeclaredVariableNode: self! ! +!UndeclaredVariableNode methodsFor: 'testing' stamp: 'eem 8/13/2010 15:34'! +isUndeclared + ^true! ! +!UndeclaredVariableNode methodsFor: 'accessing' stamp: 'eem 8/17/2010 16:30'! +tag + "Tag can be whatever one wants it to be; used by Parser to tag + undeclared temps with the user's desired declaration level." + + ^tag! ! +!UndeclaredVariableNode methodsFor: 'accessing' stamp: 'eem 8/17/2010 16:30'! +tag: anObject + "Tag can be whatever one wants it to be; used by Parser to tag + undeclared temps with the user's desired declaration level." + + tag := anObject! ! +!VariableNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 14:52' prior: 53104834! +emitCodeForLoad: stack encoder: encoder + "Do nothing"! ! +!VariableNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 16:41' prior: 53109491! +emitCodeForReturn: stack encoder: encoder + encoder + if: code + isSpecialLiteralForReturn: + [:specialLiteral| + "short returns" + encoder genReturnSpecialLiteral: specialLiteral. + stack push: 1 "doesnt seem right". + ^self]. + (self code = LdSelf or: [self code = LdSuper]) ifTrue: + ["short returns" + encoder genReturnReceiver. + stack push: 1 "doesnt seem right". + ^self]. + super emitCodeForReturn: stack encoder: encoder! ! +!VariableNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 18:08' prior: 53112316! +emitCodeForStore: stack encoder: encoder + + self shouldNotImplement! ! +!VariableNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 16:41' prior: 53106995! +emitCodeForStorePop: stack encoder: encoder + self type ~= 1 ifTrue: + [self halt]. + encoder genStorePopInstVar: index. + stack pop: 1! ! +!VariableNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 18:07' prior: 53113225! +emitCodeForValue: stack encoder: encoder + stack push: 1. + encoder + if: code + isSpecialLiteralForPush: + [:specialLiteral| + ^encoder genPushSpecialLiteral: specialLiteral]. + (code = LdSelf or: [code = LdSuper]) ifTrue: + [^encoder genPushReceiver]. + code = LdThisContext ifTrue: + [^encoder genPushThisContext]. + self flag: 'probably superfluous'. + self halt. + ^encoder genPushInstVar: index! ! +!VariableNode methodsFor: 'testing' stamp: 'eem 8/13/2010 15:34'! +isUndeclared + ^false! ! +!VariableNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 16:58' prior: 53112637! +sizeCodeForReturn: encoder + encoder + if: code + isSpecialLiteralForPush: + [:specialLiteral| + ^encoder sizeReturnSpecialLiteral: specialLiteral]. + (self code = LdSelf or: [self code = LdSuper]) ifTrue: + [^encoder sizeReturnReceiver]. + ^super sizeCodeForReturn: encoder! ! +!VariableNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 18:09' prior: 53105612! +sizeCodeForStore: encoder + self shouldNotImplement! ! +!VariableNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 18:09' prior: 53112172! +sizeCodeForStorePop: encoder + self shouldNotImplement! ! +!VariableNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 17:54' prior: 53107813! +sizeCodeForValue: encoder + self reserve: encoder. + encoder + if: code + isSpecialLiteralForPush: + [:specialLiteral| "i.e. the pseudo-variables nil true & false" + ^encoder sizePushSpecialLiteral: specialLiteral]. + (code = LdSelf or: [code = LdSuper]) ifTrue: + [^encoder sizePushReceiver]. + code = LdThisContext ifTrue: + [^encoder sizePushThisContext]. + self flag: 'probably superfluous'. + self halt. + ^encoder sizePushInstVar: index! ! +!InstanceVariableNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 18:08' prior: 51430402! +emitCodeForStore: stack encoder: encoder + encoder genStoreInstVar: index! ! +!InstanceVariableNode methodsFor: 'code generation' stamp: 'eem 5/15/2008 10:05' prior: 51430573! +emitCodeForStorePop: stack encoder: encoder + encoder genStorePopInstVar: index. + stack pop: 1! ! +!InstanceVariableNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 18:08' prior: 51430765! +emitCodeForValue: stack encoder: encoder + stack push: 1. + ^encoder genPushInstVar: index! ! +!InstanceVariableNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 17:57' prior: 51429943! +sizeCodeForStore: encoder + ^encoder sizeStoreInstVar: index! ! +!InstanceVariableNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 18:07' prior: 51430238! +sizeCodeForStorePop: encoder + ^encoder sizeStorePopInstVar: index! ! +!InstanceVariableNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 17:53' prior: 51430952! +sizeCodeForValue: encoder + ^encoder sizePushInstVar: index! ! +!FieldNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 14:52' prior: 51110966! +emitCodeForEffect: stack encoder: encoder! ! +!FieldNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 14:52' prior: 51108318! +emitCodeForLoad: stack encoder: encoder + rcvrNode emitCodeForValue: stack encoder: encoder. + fieldDef accessKey ifNotNil:[ + super emitCodeForValue: stack encoder: encoder. + ].! ! +!FieldNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 14:52' prior: 51111688! +emitCodeForStore: stack encoder: encoder + fieldDef accessKey ifNil:[ + writeNode emitCode: stack args: 1 encoder: encoder super: false. + ] ifNotNil:[ + writeNode emitCode: stack args: 2 encoder: encoder super: false. + ].! ! +!FieldNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 16:18' prior: 51111996! +emitCodeForStorePop: stack encoder: encoder + self emitCodeForStore: stack encoder: encoder. + encoder genPop. + stack pop: 1.! ! +!FieldNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 14:52' prior: 51112488! +emitCodeForValue: stack encoder: encoder + fieldDef accessKey ifNil:[ + rcvrNode emitCodeForValue: stack encoder: encoder. + readNode emitCode: stack args: 0 encoder: encoder super: false. + ] ifNotNil:[ + rcvrNode emitCodeForValue: stack encoder: encoder. + super emitCodeForValue: stack encoder: encoder. + readNode emitCode: stack args: 1 encoder: encoder super: false. + ].! ! +!FieldNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 14:52' prior: 51111095! +sizeCodeForEffect: encoder + ^0! ! +!FieldNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 14:52' prior: 51109339! +sizeCodeForStore: encoder + rcvrNode ifNil:[self encodeReceiverOn: encoder]. + fieldDef accessKey ifNil:[ + writeNode ifNil:[writeNode := encoder encodeSelector: fieldDef toSet]. + ^(rcvrNode sizeCodeForValue: encoder) + + (writeNode sizeCode: encoder args: 1 super: false) + ]. + writeNode ifNil:[writeNode := encoder encodeSelector: #set:to:]. + ^(rcvrNode sizeCodeForValue: encoder) + + (super sizeCodeForValue: encoder) + + (writeNode sizeCode: encoder args: 2 super: false)! ! +!FieldNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 17:17' prior: 51111519! +sizeCodeForStorePop: encoder + ^(self sizeCodeForStore: encoder) + encoder sizePop! ! +!FieldNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 14:52' prior: 51113121! +sizeCodeForValue: encoder + rcvrNode ifNil:[self encodeReceiverOn: encoder]. + fieldDef accessKey ifNil:[ + readNode ifNil:[readNode := encoder encodeSelector: fieldDef toGet]. + ^(rcvrNode sizeCodeForValue: encoder) + + (readNode sizeCode: encoder args: 0 super: false) + ]. + readNode ifNil:[readNode := encoder encodeSelector: #get:]. + ^(rcvrNode sizeCodeForValue: encoder) + + (super sizeCodeForValue: encoder) + + (readNode sizeCode: encoder args: 1 super: false)! ! +!AssignmentNode methodsFor: 'code generation' stamp: 'eem 6/4/2008 11:27' prior: 33547565! +emitCodeForEffect: stack encoder: encoder + + variable emitCodeForLoad: stack encoder: encoder. + value emitCodeForValue: stack encoder: encoder. + pc := encoder methodStreamPosition + 1. "debug pc is first byte of the store, i.e. the next byte". + variable emitCodeForStorePop: stack encoder: encoder! ! +!AssignmentNode methodsFor: 'code generation' stamp: 'eem 6/4/2008 11:27' prior: 33549094! +emitCodeForValue: stack encoder: encoder + + variable emitCodeForLoad: stack encoder: encoder. + value emitCodeForValue: stack encoder: encoder. + pc := encoder methodStreamPosition + 1. "debug pc is first byte of the store, i.e. the next byte". + variable emitCodeForStore: stack encoder: encoder! ! +!AssignmentNode methodsFor: 'code generation' stamp: 'eem 5/20/2008 15:16' prior: 33548242! +sizeCodeForEffect: encoder + + ^(variable sizeCodeForLoad: encoder) + + (value sizeCodeForValue: encoder) + + (variable sizeCodeForStorePop: encoder)! ! +!AssignmentNode methodsFor: 'code generation' stamp: 'eem 5/20/2008 15:16' prior: 33549711! +sizeCodeForValue: encoder + + ^(variable sizeCodeForLoad: encoder) + + (value sizeCodeForValue: encoder) + + (variable sizeCodeForStore: encoder)! ! +!Decompiler methodsFor: 'public access' stamp: 'eem 8/12/2010 13:46' prior: 35376369! +decompileBlock: aBlock + "Decompile aBlock, returning the result as a BlockNode. + Show temp names from source if available." + "Decompiler new decompileBlock: [3 + 4]" + | startpc end homeClass blockNode methodNode home | + (home := aBlock home) ifNil: [^ nil]. + method := home method. + (homeClass := home methodClass) == #unknown ifTrue: [^ nil]. + aBlock isClosure ifTrue: + [(methodNode := method decompileWithTemps) + ifNil: [^nil] + ifNotNil: [methodNode nodesDo: [:node| node pc = aBlock startpc ifTrue: [^node]]]. + ^self error: 'cannot find block node matching aBlock']. + constructor := self constructorForMethod: aBlock method. + + self withTempNames: method methodNode tempNames. + + self initSymbols: homeClass. + startpc := aBlock startpc. + end := aBlock endPC. + stack := OrderedCollection new: method frameSize. + caseExits := OrderedCollection new. + 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! ! +!Decompiler methodsFor: 'control' stamp: 'eem 8/12/2010 13:25' prior: 50903238! +doClosureCopyCopiedValues: blockCopiedValues numArgs: numArgs blockSize: blockSize + | startpc savedTemps savedTempVarCount savedNumLocalTemps + jump blockArgs blockTemps blockTempsOffset block | + savedTemps := tempVars. + savedTempVarCount := tempVarCount. + savedNumLocalTemps := numLocalTemps. + jump := blockSize + (startpc := pc). + numLocalTemps := BlockLocalTempCounter tempCountForBlockAt: pc - 4 in: method. + blockTempsOffset := numArgs + blockCopiedValues size. + (blockStartsToTempVars notNil "implies we were intialized with temp names." + and: [blockStartsToTempVars includesKey: pc]) + ifTrue: + [tempVars := blockStartsToTempVars at: pc] + ifFalse: + [blockArgs := (1 to: numArgs) collect: + [:i| (constructor + codeTemp: i - 1 + named: 't', (tempVarCount + i) printString) + beBlockArg]. + blockTemps := (1 to: numLocalTemps) collect: + [:i| constructor + codeTemp: i + blockTempsOffset - 1 + named: 't', (tempVarCount + i + numArgs) printString]. + tempVars := blockArgs, blockCopiedValues, blockTemps]. + numLocalTemps timesRepeat: + [self interpretNextInstructionFor: self. + stack removeLast]. + tempVarCount := tempVarCount + numArgs + numLocalTemps. + block := self blockTo: jump. + stack addLast: ((constructor + codeArguments: (tempVars copyFrom: 1 to: numArgs) + temps: (tempVars copyFrom: blockTempsOffset + 1 to: blockTempsOffset + numLocalTemps) + block: block) + pc: startpc; + yourself). + tempVars := savedTemps. + tempVarCount := savedTempVarCount. + numLocalTemps := savedNumLocalTemps! ! +!Decompiler methodsFor: 'instruction decoding' stamp: 'eem 8/12/2010 13:51' prior: 50907292! +pushClosureCopyNumCopiedValues: numCopied numArgs: numArgs blockSize: blockSize + | copiedValues | + self sawClosureBytecode. + copiedValues := ((1 to: numCopied) collect: [:ign| stack removeLast]) reversed. + self doClosureCopyCopiedValues: copiedValues numArgs: numArgs blockSize: blockSize! ! +!LiteralVariableNode methodsFor: 'code generation' stamp: 'eem 5/15/2008 09:44' prior: 51563596! +emitCodeForLoad: stack encoder: encoder + writeNode ifNotNil: + [encoder genPushLiteral: index. + stack push: 1]! ! +!LiteralVariableNode methodsFor: 'code generation' stamp: 'eem 5/15/2008 10:43' prior: 51567069! +emitCodeForStore: stack encoder: encoder + writeNode ifNil: [^encoder genStoreLiteralVar: index]. + "THIS IS WRONG!!!! THE VALUE IS LOST FROM THE STACK!!!! + The various value: methods on Association ReadOnlyVariableBinding + etc _do not_ return the value assigned; they return the receiver." + "Should generate something more like + push expr + push lit + push temp (index of expr) + send value: + pop + or use e.g. valueForStore:" + self flag: #bogus. + writeNode + emitCode: stack + args: 1 + encoder: encoder + super: false! ! +!LiteralVariableNode methodsFor: 'code generation' stamp: 'eem 5/15/2008 10:09' prior: 51567688! +emitCodeForStorePop: stack encoder: encoder + writeNode ifNil: + [stack pop: 1. + ^encoder genStorePopLiteralVar: index]. + self emitCodeForStore: stack encoder: encoder. + encoder genPop. + stack pop: 1.! ! +!LiteralVariableNode methodsFor: 'code generation' stamp: 'nice 7/23/2010 23:17' prior: 51567987! +emitCodeForValue: stack encoder: encoder + ^readNode + ifNil: [stack push: 1. + encoder genPushLiteralVar: index] + ifNotNil: [readNode emitCodeForValue: stack encoder: encoder]! ! +!LiteralVariableNode methodsFor: 'code generation' stamp: 'nice 8/17/2010 22:26' prior: 51564699! +sizeCodeForLoad: encoder + self reserve: encoder. + ^(key isVariableBinding and: [key isSpecialWriteBinding]) + ifTrue: [encoder sizePushLiteral: index] + ifFalse: [0]! ! +!LiteralVariableNode methodsFor: 'code generation' stamp: 'nice 8/17/2010 22:27' prior: 51564887! +sizeCodeForStore: encoder + self reserve: encoder. + (key isVariableBinding and: [key isSpecialWriteBinding]) ifFalse: + [^encoder sizeStoreLiteralVar: index]. + code < 0 ifTrue: + [self flag: #dubious. + self code: (self code: self index type: LdLitType)]. + "THIS IS WRONG!!!! THE VALUE IS LOST FROM THE STACK!!!! + The various value: methods on Association ReadOnlyVariableBinding + etc _do not_ return the value assigned; they return the receiver." + "Should generate something more like + push expr + push lit + push temp (index of expr) + send value: + pop" + self flag: #bogus. + writeNode := encoder encodeSelector: #value:. + ^writeNode sizeCode: encoder args: 1 super: false! ! +!LiteralVariableNode methodsFor: 'code generation' stamp: 'eem 5/20/2010 08:55' prior: 36496517! +sizeCodeForStorePop: encoder + self reserve: encoder. + ^(key isVariableBinding and: [key isSpecialWriteBinding]) + ifTrue: [(self sizeCodeForStore: encoder) + encoder sizePop] + ifFalse: [encoder sizeStorePopLiteralVar: index]! ! +!LiteralVariableNode methodsFor: 'code generation' stamp: 'nice 7/23/2010 23:58' prior: 51568428! +sizeCodeForValue: encoder + self reserve: encoder. + (key isVariableBinding and: [key isSpecialReadBinding]) + ifFalse: + [^encoder sizePushLiteralVar: index]. + readNode := MessageNode new + receiver: (encoder encodeLiteral: key) + selector: (encoder encodeSelector: #value) + arguments: #() + precedence: #value precedence. + ^readNode sizeCodeForValue: encoder! ! +!Parser methodsFor: 'error correction' stamp: 'eem 7/6/2010 15:07' prior: 52094356! +declareClassVar: name + | sym class | + sym := name asSymbol. + class := encoder classEncoding. + class := class theNonMetaClass. "not the metaclass" + class addClassVarName: name. + Smalltalk logChange: class definition. + ^ encoder global: (class classPool associationAt: sym) + name: sym! ! +!Parser methodsFor: 'error correction' stamp: 'eem 5/6/2010 21:14' prior: 52081547! +declareInstVar: name + "Declare an instance variable. Since the variable will get added after any existing + inst vars its index is the instSize." + encoder classEncoding addInstVarName: name. + Smalltalk logChange: encoder classEncoding definition. + ^InstanceVariableNode new name: name index: encoder classEncoding instSize + ! ! +!Parser methodsFor: 'error correction' stamp: 'eem 8/17/2010 16:35'! +declareTemp: name at: levelTag + "Defer declaring the temp until the parse has completed. This allows + the parser to declare the temp in the minimum enclosing block instead + of always at method level. See Parser>>declareUndeclaredTemps:" + ^(encoder bindUndeclaredTemp: name) + tag: levelTag; + yourself! ! +!Parser methodsFor: 'error correction' stamp: 'eem 8/14/2010 19:34' prior: 52098032! +declareTempAndPaste: name + "Defer declaring the temp until the parse has completed. This allows + the parser to declare the temp in the minimum enclosing block instead + of always at method level. See Parser>>declareUndeclaredTemps:" + ^encoder bindUndeclaredTemp: name! ! +!Parser methodsFor: 'error correction' stamp: 'eem 8/17/2010 16:37'! +declareUndeclaredTemps: methodNode + "Declare any undeclared temps, declaring them at the smallest enclosing scope." + + | undeclared userSelection blocksToVars | + (undeclared := encoder undeclaredTemps) isEmpty ifTrue: + [^self]. + userSelection := 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]]. + requestor selectInvisiblyFrom: userSelection first to: userSelection last + requestorOffset. + ReparseAfterSourceEditing signal! ! +!Parser methodsFor: 'expression types' stamp: 'eem 8/13/2010 16:48' prior: 58135859! +method: doit context: ctxt + " pattern [ | temporaries ] block => MethodNode." + + | sap blk prim temps messageComment methodNode | + sap := self pattern: doit inContext: ctxt. + "sap={selector, arguments, precedence}" + self properties selector: (sap at: 1). + encoder selector: (sap at: 1). + (sap at: 2) do: [:argNode | argNode beMethodArg]. + doit ifFalse: [self pragmaSequence]. + temps := self temporaries. + messageComment := currentComment. + currentComment := nil. + doit ifFalse: [self pragmaSequence]. + prim := self pragmaPrimitives. + self statements: #() innerBlock: doit. + blk := parseNode. + doit ifTrue: [blk returnLast] + ifFalse: [blk returnSelfIfNoOther: encoder]. + hereType == #doIt ifFalse: [^self expected: 'Nothing more']. + methodNode := self newMethodNode comment: messageComment. + methodNode + selector: (sap at: 1) + arguments: (sap at: 2) + precedence: (sap at: 3) + temporaries: temps + block: blk + encoder: encoder + primitive: prim + properties: properties. + self interactive ifTrue: + [self declareUndeclaredTemps: methodNode. + self removeUnusedTemps]. + ^methodNode! ! +!Parser methodsFor: 'public access' stamp: 'eem 8/16/2010 18:08' prior: 58137920! +parse: sourceStream class: class category: aCategory 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 subSelection | + category := aCategory. + myStream := sourceStream. + [repeatNeeded := false. + p := myStream position. + s := myStream upToEnd. + myStream position: p. + subSelection := req notNil and: [req selectionInterval = (p + 1 to: p + s size)]. + self encoder init: class context: ctxt notifying: self. + self init: myStream notifying: req failBlock: [^ aBlock value]. + doitFlag := noPattern. + failBlock:= aBlock. + [methNode := self + method: noPattern + context: ctxt] + on: ReparseAfterSourceEditing + do: [ :ex | + repeatNeeded := true. + myStream := subSelection + ifTrue: + [ReadStream + on: requestor text string + from: requestor selectionInterval first + to: requestor selectionInterval last] + ifFalse: + [ReadStream on: requestor text string]]. + repeatNeeded] whileTrue: + [encoder := self encoder class new]. + methNode sourceText: s. + ^methNode! ! +!Parser methodsFor: 'error correction' stamp: 'eem 8/13/2010 19:34'! +pasteTempAtMethodLevel: name + | insertion delta theTextString characterBeforeMark | + + theTextString := 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: 'eem 8/15/2010 08:56' prior: 54012081! +removeUnusedTemps + "Scan for unused temp names, and prompt the user about the prospect of removing each one found" + + | str madeChanges | + madeChanges := false. + str := requestor text asString. + ((tempsMark between: 1 and: str size) + and: [(str at: tempsMark) = $|]) ifFalse: [^ self]. + encoder unusedTempNames do: + [:temp | | start end | + (UnusedVariable name: temp) ifTrue: + [(encoder lookupVariable: temp ifAbsent: []) 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' withCRs]]]. + madeChanges ifTrue: [ReparseAfterSourceEditing signal]! ! +!Parser methodsFor: 'error correction' stamp: 'eem 8/14/2010 10:32' prior: 52101384! +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." + + 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: 'eem 8/13/2010 10:35' prior: 52088916! +temporaries + " [ '|' (variable)* '|' ]" + | vars theActualText | + (self match: #verticalBar) ifFalse: + ["no temps" + doitFlag ifTrue: + [tempsMark := self interactive + ifTrue: [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: 'eem 8/13/2010 10:35' prior: 52090927! +temporariesIn: methodSelector + " [ '|' (variable)* '|' ]" + | vars theActualText | + (self match: #verticalBar) ifFalse: + ["no temps" + doitFlag ifTrue: + [tempsMark := self interactive + ifTrue: [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'! ! +!Parser methodsFor: 'expression types' stamp: 'eem 8/13/2010 15:57' prior: 52077730! +temporaryBlockVariablesFor: aBlockNode + "Scan and answer temporary block variables." + + | variables | + (self match: #verticalBar) ifFalse: + "There are't any temporary variables." + [aBlockNode tempsMark: prevMark + requestorOffset. + ^#()]. + + variables := OrderedCollection new. + [hereType == #word] whileTrue: + [variables addLast: (encoder bindBlockTemp: self advance within: aBlockNode)]. + (self match: #verticalBar) ifFalse: + [^self expected: 'Vertical bar']. + aBlockNode tempsMark: prevMark + requestorOffset. + ^variables! ! +!MaybeContextInstanceVariableNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 18:08' prior: 51621449! +emitCodeForStore: stack encoder: encoder + encoder genStoreInstVarLong: index! ! +!MaybeContextInstanceVariableNode methodsFor: 'code generation' stamp: 'eem 6/19/2008 09:36' prior: 51621636! +emitCodeForStorePop: stack encoder: encoder + encoder genStorePopInstVarLong: index. + stack pop: 1! ! +!MaybeContextInstanceVariableNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 18:08' prior: 51621844! +emitCodeForValue: stack encoder: encoder + stack push: 1. + ^encoder genPushInstVarLong: index! ! +!MaybeContextInstanceVariableNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 17:57' prior: 51621095! +sizeCodeForStore: encoder + ^encoder sizeStoreInstVarLong: index! ! +!MaybeContextInstanceVariableNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 18:07' prior: 51621269! +sizeCodeForStorePop: encoder + ^encoder sizeStorePopInstVarLong: index! ! +!MaybeContextInstanceVariableNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 17:53' prior: 51622047! +sizeCodeForValue: encoder + ^encoder sizePushInstVarLong: index! ! +!Compiler methodsFor: 'public access' stamp: 'ar 9/27/2005 19:20' prior: 19116591! +compile: textOrStream in: aClass classified: aCategory notifying: aRequestor ifFail: failBlock + "Answer a MethodNode for the argument, textOrStream. If the + MethodNode can not be created, notify the argument, aRequestor; if + aRequestor 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 argument, aClass." + + self from: textOrStream + class: aClass + classified: aCategory + context: nil + notifying: aRequestor. + ^self + translate: sourceStream + noPattern: false + ifFail: failBlock +! ! +!Compiler methodsFor: 'public access' stamp: 'eem 8/14/2010 20:23' prior: 50779925! +from: textOrStream class: aClass classified: aCategory context: aContext notifying: req + + sourceStream := (textOrStream isKindOf: PositionableStream) + ifTrue: [textOrStream] + ifFalse: [ReadStream on: textOrStream asString]. + class := aClass. + context := aContext. + requestor := req. + category := aCategory +! ! +!NewArrayNode methodsFor: 'code generation' stamp: 'eem 5/25/2008 14:58' prior: 51916787! +emitCodeForValue: stack encoder: encoder + encoder genPushNewArray: numElements. + stack push: 1! ! +!NewArrayNode methodsFor: 'code generation' stamp: 'eem 5/25/2008 14:58' prior: 51917069! +sizeCodeForValue: encoder + ^encoder sizePushNewArray: numElements! ! +!CascadeNode methodsFor: 'code generation' stamp: 'eem 5/15/2008 09:41' prior: 50569842! +emitCodeForValue: stack encoder: encoder + receiver emitCodeForValue: stack encoder: encoder. + 1 to: messages size - 1 do: + [:i | + encoder genDup. + stack push: 1. + (messages at: i) emitCodeForValue: stack encoder: encoder. + encoder genPop. + stack pop: 1]. + messages last emitCodeForValue: stack encoder: encoder! ! +!CascadeNode methodsFor: 'code generation' stamp: 'eem 5/15/2008 09:39' prior: 50570250! +sizeCodeForValue: encoder + | size | + size := (receiver sizeCodeForValue: encoder) + + (messages size - 1 * (encoder sizeDup + encoder sizePop)). + messages do: [:aMessage | size := size + (aMessage sizeCodeForValue: encoder)]. + ^size! ! +!Scanner methodsFor: 'expression types' stamp: 'eem 7/2/2010 10:07' prior: 53392053! +scanAllTokenPositionsInto: aBlock + "Evaluate aBlock with the start and end positions of all separate non-white-space tokens, including comments." + + | lastMark | + lastMark := 1. + [currentComment notNil ifTrue: + [currentComment do: + [:cmnt| | idx | + idx := source originalContents indexOfSubCollection: cmnt startingAt: lastMark. + (idx > 0 and: [idx < mark]) ifTrue: + [aBlock value: idx - 1 value: (lastMark := idx + cmnt size)]]. + currentComment := nil]. + mark notNil ifTrue: + [(token == #- + and: [(self typeTableAt: hereChar) = #xDigit]) ifTrue: + [| savedMark | + savedMark := mark. + self scanToken. + token := token negated. + mark := savedMark]. + "Compensate for the fact that the parser uses two character lookahead. Normally we must + remove the extra two characters. But this mustn't happen for the last token at the end of stream." + aBlock + value: mark + value: (source atEnd + ifTrue: [tokenType := #doIt. "to cause an immediate ^self" source position] + ifFalse: [source position - 2])]. + (tokenType = #rightParenthesis + or: [tokenType == #doIt]) ifTrue: + [^self]. + tokenType = #leftParenthesis + ifTrue: + [self scanToken; scanAllTokenPositionsInto: aBlock] + ifFalse: + [(tokenType = #word or: [tokenType = #keyword or: [tokenType = #colon]]) + ifTrue: + [self scanLitWord. + token = #true ifTrue: [token := true]. + token = #false ifTrue: [token := false]. + token = #nil ifTrue: [token := nil]] + ifFalse: + [(token == #- + and: [(self typeTableAt: hereChar) = #xDigit]) + ifTrue: + [self scanToken. + token := token negated]]]. + self scanToken. + true] whileTrue! ! +!Scanner methodsFor: 'multi-character scans' stamp: 'nice 7/25/2010 12:23' prior: 53393807! +xIllegal + "An illegal character was encountered" + self notify: 'Illegal character (char code ' , hereChar charCode , ' ' , hereChar charCode storeStringHex , ')' at: mark! ! +!UndeclaredVariable methodsFor: 'as yet unclassified' stamp: 'eem 8/17/2010 16:35' prior: 58108085! +openMenuIn: aBlock + | alternatives labels actions lines caption choice | + alternatives := parser possibleVariablesFor: name. + labels := OrderedCollection new. + actions := OrderedCollection new. + lines := OrderedCollection new. + name first isLowercase + ifTrue: + [labels add: 'declare method temp'. + actions add: [parser declareTemp: name at: #method]. + labels add: 'declare block-local temp'. + actions add: [parser declareTemp: name at: #block]. + labels add: 'declare instance'. + actions add: [parser declareInstVar: name]] + ifFalse: + [labels add: 'define new class'. + actions add: [parser defineClass: name]. + labels add: 'declare global'. + actions add: [parser declareGlobal: name]. + parser canDeclareClassVariable + ifTrue: + [labels add: 'declare class variable'. + actions add: [parser declareClassVar: name]]]. + lines add: labels size. + alternatives do: + [:each | + labels add: each. + actions add: [parser substituteVariable: each atInterval: interval]]. + lines add: labels size. + labels add: 'cancel'. + caption := 'Unknown variable: ' , name , ' please correct, or cancel:'. + choice := aBlock value: labels value: lines value: caption. + self resume: (actions at: choice ifAbsent: [nil])! ! +!MessageAsTempNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 14:52' prior: 51625745! +emitCodeForStorePop: stack encoder: encoder + "This node has the form {expr storeAt: offset inTempFrame: homeContext}, + where the expr, the block argument, is already on the stack." + ^self emitCodeForEffect: stack encoder: encoder! ! +!MessageAsTempNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 14:52' prior: 51625450! +sizeCodeForStorePop: encoder + "This node has the form {expr storeAt: offset inTempFrame: homeContext}, + where the expr, the block argument, is already on the stack." + ^self sizeCodeForEffect: encoder! ! +!BlockNode methodsFor: 'code generation (closures)' stamp: 'nice 8/19/2010 16:31' prior: 50452197! +computeCopiedValues: rootNode + | referencedValues | + referencedValues := rootNode referencedValuesWithinBlockExtent: blockExtent. + ^(referencedValues reject: [:temp| temp isDefinedWithinBlockExtent: blockExtent]) + asArray sort: ParseNode tempSortBlock! ! +!BlockNode methodsFor: 'code generation' stamp: 'eem 6/2/2008 13:29' prior: 50469704! +emitCodeExceptLast: stack encoder: encoder + | position nextToLast | + position := stack position. + nextToLast := statements size - 1. + 1 to: nextToLast do: + [:i | | statement | + statement := statements at: i. + statement emitCodeForEffect: stack encoder: encoder. + self assert: stack position = position].! ! +!BlockNode methodsFor: 'code generation' stamp: 'eem 5/21/2008 11:28' prior: 50441069! +emitCodeForEvaluatedEffect: stack encoder: encoder + | position | + position := stack position. + self returns + ifTrue: + [self emitCodeForEvaluatedValue: stack encoder: encoder. + stack pop: 1] + ifFalse: + [self emitCodeExceptLast: stack encoder: encoder. + statements last emitCodeForEffect: stack encoder: encoder]. + self assert: stack position = position! ! +!BlockNode methodsFor: 'code generation' stamp: 'eem 5/21/2008 11:36' prior: 50447264! +emitCodeForEvaluatedValue: stack encoder: encoder + | position | + position := stack position. + self emitCodeExceptLast: stack encoder: encoder. + statements last emitCodeForBlockValue: stack encoder: encoder. + self assert: stack position - 1 = position! ! +!BlockNode methodsFor: 'code generation' stamp: 'eem 5/20/2008 16:55' prior: 50454333! +emitCodeForValue: stack encoder: encoder + + self generateAsClosure ifTrue: + [^self emitCodeForClosureValue: stack encoder: encoder]. + encoder genPushThisContext. + stack push: 1. + nArgsNode emitCodeForValue: stack encoder: encoder. + remoteCopyNode + emitCode: stack + args: 1 + encoder: encoder. + "Force a two byte jump." + encoder genJumpLong: size. + stack push: arguments size. + arguments reverseDo: [:arg | arg emitCodeForStorePop: stack encoder: encoder]. + self emitCodeForEvaluatedValue: stack encoder: encoder. + self returns ifFalse: + [encoder genReturnTopToCaller. + pc := encoder methodStreamPosition]. + stack pop: 1! ! +!BlockNode methodsFor: 'code generation' stamp: 'eem 5/29/2008 15:21' prior: 50455290! +sizeCodeExceptLast: encoder + | codeSize | + codeSize := 0. + 1 to: statements size - 1 do: + [:i | | statement | + statement := statements at: i. + codeSize := codeSize + (statement sizeCodeForEffect: encoder)]. + ^codeSize! ! +!BlockNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 17:13' prior: 50447760! +sizeCodeForEvaluatedEffect: encoder + + ^self returns + ifTrue: [self sizeCodeForEvaluatedValue: encoder] + ifFalse: [(self sizeCodeExceptLast: encoder) + + (statements last sizeCodeForEffect: encoder)]! ! +!BlockNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 14:52' prior: 50467762! +sizeCodeForEvaluatedValue: encoder + + ^(self sizeCodeExceptLast: encoder) + + (statements last sizeCodeForBlockValue: encoder)! ! +!BlockNode methodsFor: 'code generation' stamp: 'eem 5/20/2008 16:55' prior: 50462928! +sizeCodeForValue: encoder + self generateAsClosure ifTrue: + [^self sizeCodeForClosureValue: encoder]. + + nArgsNode := encoder encodeLiteral: arguments size. + remoteCopyNode := encoder encodeSelector: #blockCopy:. + size := self sizeCodeForEvaluatedValue: encoder. + self returns ifFalse: + [size := size + encoder sizeReturnTopToCaller]. "endBlock" + arguments := arguments collect: "Chance to prepare debugger remote temps" + [:arg | arg asStorableNode: encoder]. + arguments do: [:arg | size := size + (arg sizeCodeForStorePop: encoder)]. + ^encoder sizePushThisContext + + (nArgsNode sizeCodeForValue: encoder) + + (remoteCopyNode sizeCode: encoder args: 1 super: false) + + (encoder sizeJumpLong: size) + + size! ! +!BlockNode methodsFor: 'accessing' stamp: 'eem 8/13/2010 15:44'! +tempsMark + ^tempsMark! ! +!BlockNode methodsFor: 'accessing' stamp: 'eem 8/13/2010 15:44'! +tempsMark: anInteger + tempsMark := anInteger! ! +!MessageNode class methodsFor: 'class initialization' stamp: 'eem 8/15/2010 10:22' prior: 55928326! +initialize "MessageNode initialize" + MacroSelectors := + #( ifTrue: ifFalse: ifTrue:ifFalse: ifFalse:ifTrue: + and: or: + whileFalse: whileTrue: whileFalse whileTrue + to:do: to:by:do: + caseOf: caseOf:otherwise: + ifNil: ifNotNil: ifNil:ifNotNil: ifNotNil:ifNil:). + MacroTransformers := + #( transformIfTrue: transformIfFalse: transformIfTrueIfFalse: transformIfFalseIfTrue: + transformAnd: transformOr: + transformWhile: transformWhile: transformWhile: transformWhile: + transformToDo: transformToDo: + transformCase: transformCase: + transformIfNil: transformIfNil: transformIfNilIfNotNil: transformIfNotNilIfNil:). + MacroEmitters := + #( emitCodeForIf:encoder:value: emitCodeForIf:encoder:value: + emitCodeForIf:encoder:value: emitCodeForIf:encoder:value: + emitCodeForIf:encoder:value: emitCodeForIf:encoder:value: + emitCodeForWhile:encoder:value: emitCodeForWhile:encoder:value: + emitCodeForWhile:encoder:value: emitCodeForWhile:encoder:value: + emitCodeForToDo:encoder:value: emitCodeForToDo:encoder:value: + emitCodeForCase:encoder:value: emitCodeForCase:encoder:value: + emitCodeForIfNil:encoder:value: emitCodeForIfNil:encoder:value: + emitCodeForIf:encoder:value: emitCodeForIf:encoder:value:). + MacroSizers := + #( sizeCodeForIf:value: sizeCodeForIf:value: sizeCodeForIf:value: sizeCodeForIf:value: + sizeCodeForIf:value: sizeCodeForIf:value: + sizeCodeForWhile:value: sizeCodeForWhile:value: sizeCodeForWhile:value: sizeCodeForWhile:value: + sizeCodeForToDo:value: sizeCodeForToDo:value: + sizeCodeForCase:value: sizeCodeForCase:value: + sizeCodeForIfNil:value: sizeCodeForIfNil:value: sizeCodeForIf:value: sizeCodeForIf:value:). + MacroPrinters := + #( printIfOn:indent: printIfOn:indent: printIfOn:indent: printIfOn:indent: + printIfOn:indent: printIfOn:indent: + printWhileOn:indent: printWhileOn:indent: printWhileOn:indent: printWhileOn:indent: + printToDoOn:indent: printToDoOn:indent: + printCaseOn:indent: printCaseOn:indent: + printIfNil:indent: printIfNil:indent: printIfNilNotNil:indent: printIfNilNotNil:indent:)! ! +!MessageNode methodsFor: 'code generation' stamp: 'eem 9/29/2008 14:45' prior: 51652863! +emitCodeForCase: stack encoder: encoder value: forValue + + | braceNode sizeStream allReturn | + forValue ifFalse: + [^super emitCodeForEffect: stack encoder: encoder]. + braceNode := arguments first. + sizeStream := ReadStream on: sizes. + receiver emitCodeForValue: stack encoder: encoder. + "There must be at least one branch around the otherwise/caseError + so the decompiler can identify the end of the otherwise/caseError." + allReturn := true. "assume every case ends with a return" + braceNode casesForwardDo: + [:keyNode :valueNode :last | | thenSize elseSize | + thenSize := sizeStream next. + elseSize := sizeStream next. + last ifFalse: [encoder genDup. stack push: 1]. + keyNode emitCodeForEvaluatedValue: stack encoder: encoder. + equalNode emitCode: stack args: 1 encoder: encoder. + self emitCodeForBranchOn: false dist: thenSize pop: stack encoder: encoder. + last ifFalse: [encoder genPop. stack pop: 1]. + valueNode emitCodeForEvaluatedValue: stack encoder: encoder. + last ifTrue: [stack pop: 1]. + valueNode returns ifFalse: + [self emitCodeForJump: elseSize encoder: encoder. + allReturn := false]. + (last and: [allReturn]) ifTrue: + [self emitCodeForJump: elseSize encoder: encoder]]. + arguments size = 2 + ifTrue: + [arguments last emitCodeForEvaluatedValue: stack encoder: encoder] "otherwise: [...]" + ifFalse: + [NodeSelf emitCodeForValue: stack encoder: encoder. + caseErrorNode emitCode: stack args: 0 encoder: encoder]! ! +!MessageNode methodsFor: 'code generation' stamp: 'eem 8/15/2010 10:23' prior: 51635767! +emitCodeForEffect: stack encoder: encoder + "For #ifTrue:ifFalse: and #whileTrue: / #whileFalse: style messages, the pc is set to the jump instruction, so that mustBeBoolean exceptions can be shown correctly." + special > 0 + ifTrue: + [pc := 0. + self perform: (MacroEmitters at: special) with: stack with: encoder with: false] + ifFalse: + [super emitCodeForEffect: stack encoder: encoder]! ! +!MessageNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 17:12' prior: 51663950! +emitCodeForIf: stack encoder: encoder value: forValue + | thenExpr thenSize elseExpr elseSize | + thenSize := sizes at: 1. + elseSize := sizes at: 2. + (forValue not and: [elseSize * thenSize > 0]) ifTrue: + "Two-armed IFs forEffect share a single pop" + [^super emitCodeForEffect: stack encoder: encoder]. + thenExpr := arguments at: 1. + elseExpr := arguments at: 2. + receiver emitCodeForValue: stack encoder: encoder. + forValue + ifTrue: "Code all forValue as two-armed" + [self emitCodeForBranchOn: false dist: thenSize pop: stack encoder: encoder. + pc := encoder methodStreamPosition. + thenExpr emitCodeForEvaluatedValue: stack encoder: encoder. + stack pop: 1. "then and else alternate; they don't accumulate" + thenExpr returns not ifTrue: + "...not ifTrue: avoids using ifFalse: alone during this compile)" + "Elide jump over else after a return" + [self emitCodeForJump: elseSize encoder: encoder]. + elseExpr emitCodeForEvaluatedValue: stack encoder: encoder] + ifFalse: "One arm is empty here (two-arms code forValue)" + [thenSize > 0 + ifTrue: + [self emitCodeForBranchOn: false dist: thenSize pop: stack encoder: encoder. + pc := encoder methodStreamPosition. + thenExpr emitCodeForEvaluatedEffect: stack encoder: encoder] + ifFalse: + [self emitCodeForBranchOn: true dist: elseSize pop: stack encoder: encoder. + pc := encoder methodStreamPosition. + elseExpr emitCodeForEvaluatedEffect: stack encoder: encoder]]! ! +!MessageNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 16:28' prior: 51667642! +emitCodeForIfNil: stack encoder: encoder value: forValue + + | theNode theSize ifNotNilSelector | + theNode := arguments first. + theSize := sizes at: 1. + ifNotNilSelector := #ifNotNil:. + receiver emitCodeForValue: stack encoder: encoder. + forValue ifTrue: [encoder genDup. stack push: 1]. + encoder genPushSpecialLiteral: nil. stack push: 1. + equalNode emitCode: stack args: 1 encoder: encoder. + self + emitCodeForBranchOn: (selector key == ifNotNilSelector) + dist: theSize + pop: stack + encoder: encoder. + pc := encoder methodStreamPosition. + forValue + ifTrue: + [encoder genPop. stack pop: 1. + theNode emitCodeForEvaluatedValue: stack encoder: encoder] + ifFalse: [theNode emitCodeForEvaluatedEffect: stack encoder: encoder]! ! +!MessageNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 16:31' prior: 51630709! +emitCodeForToDo: stack encoder: encoder value: forValue + " var := rcvr. L1: [var <= arg1] Bfp(L2) [block body. var := var + inc] Jmp(L1) L2: " + | loopSize initStmt limitInit test block incStmt blockSize | + initStmt := arguments at: 4. + limitInit := arguments at: 7. + test := arguments at: 5. + block := arguments at: 3. + incStmt := arguments at: 6. + blockSize := sizes at: 1. + loopSize := sizes at: 2. + limitInit == nil + ifFalse: [limitInit emitCodeForEffect: stack encoder: encoder]. + initStmt emitCodeForEffect: stack encoder: encoder. + test emitCodeForValue: stack encoder: encoder. + self emitCodeForBranchOn: false dist: blockSize pop: stack encoder: encoder. + pc := encoder methodStreamPosition. + block emitCodeForEvaluatedEffect: stack encoder: encoder. + incStmt emitCodeForEffect: stack encoder: encoder. + self emitCodeForJump: 0 - loopSize encoder: encoder. + forValue ifTrue: [encoder genPushSpecialLiteral: nil. stack push: 1]! ! +!MessageNode methodsFor: 'code generation' stamp: 'eem 8/15/2010 10:23' prior: 51666291! +emitCodeForValue: stack encoder: encoder + "For #ifTrue:ifFalse: and #whileTrue: / #whileFalse: style messages, the pc is set to the jump instruction, so that mustBeBoolean exceptions can be shown correctly." + special > 0 + ifTrue: + [pc := 0. + self perform: (MacroEmitters at: special) with: stack with: encoder with: true] + ifFalse: + [receiver ~~ nil ifTrue: [receiver emitCodeForValue: stack encoder: encoder]. + arguments do: [:argument | argument emitCodeForValue: stack encoder: encoder]. + pc := encoder methodStreamPosition + 1. "debug pc is first byte of the send, i.e. the next byte". + selector + emitCode: stack + args: arguments size + encoder: encoder + super: receiver == NodeSuper]! ! +!MessageNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 16:36' prior: 51677780! +emitCodeForWhile: stack encoder: encoder value: forValue + "L1: ... Bfp(L2)|Btp(L2) ... Jmp(L1) L2: " + | cond stmt stmtSize loopSize | + cond := receiver. + stmt := arguments at: 1. + stmtSize := sizes at: 1. + loopSize := sizes at: 2. + cond emitCodeForEvaluatedValue: stack encoder: encoder. + self emitCodeForBranchOn: (selector key == #whileFalse:) "Bfp for whileTrue" + dist: stmtSize pop: stack encoder: encoder. "Btp for whileFalse" + pc := encoder methodStreamPosition. + stmt emitCodeForEvaluatedEffect: stack encoder: encoder. + self emitCodeForJump: 0 - loopSize encoder: encoder. + forValue ifTrue: [encoder genPushSpecialLiteral: nil. stack push: 1]! ! +!MessageNode methodsFor: 'code generation' stamp: 'nice 12/27/2009 03:11' prior: 54015765! +sizeCodeForCase: encoder value: forValue + + | braceNode sizeIndex elseSize allReturn | + forValue not ifTrue: + [^super sizeCodeForEffect: encoder]. + equalNode := encoder encodeSelector: #=. + braceNode := arguments first. + sizes := Array new: 2 * braceNode numElements. + sizeIndex := sizes size. + elseSize := arguments size = 2 + ifTrue: + [arguments last sizeCodeForEvaluatedValue: encoder] "otherwise: [...]" + ifFalse: + [caseErrorNode := encoder encodeSelector: #caseError. + (NodeSelf sizeCodeForValue: encoder) + + (caseErrorNode sizeCode: encoder args: 0 super: false)]. "self caseError" + "There must be at least one branch around the otherwise/caseError + so the decompiler can identify the end of the otherwise/caseError." + allReturn := true. "assume every case ends with a return" + braceNode casesForwardDo: + [:keyNode :valueNode :last | + valueNode returns ifFalse: [allReturn := false]]. + braceNode casesReverseDo: + [:keyNode :valueNode :last | | thenSize | + sizes at: sizeIndex put: elseSize. + thenSize := valueNode sizeCodeForEvaluatedValue: encoder. + last ifFalse: [thenSize := thenSize + encoder sizePop]. + valueNode returns ifFalse: [thenSize := thenSize + (self sizeCode: encoder forJump: elseSize)]. + (last and: [allReturn]) ifTrue: [thenSize := thenSize + (self sizeCode: encoder forJump: elseSize)]. + sizes at: sizeIndex-1 put: thenSize. + last ifFalse: [elseSize := elseSize + encoder sizeDup]. + elseSize := elseSize + + (keyNode sizeCodeForEvaluatedValue: encoder) + + (equalNode sizeCode: encoder args: 1 super: false) + + (self sizeCode: encoder forBranchOn: false dist: thenSize) + + thenSize. + sizeIndex := sizeIndex - 2]. + ^(receiver sizeCodeForValue: encoder) + elseSize! ! +!MessageNode methodsFor: 'code generation' stamp: 'eem 8/15/2010 10:22' prior: 51636259! +sizeCodeForEffect: encoder + + special > 0 + ifTrue: [^self perform: (MacroSizers at: special) with: encoder with: false]. + ^super sizeCodeForEffect: encoder! ! +!MessageNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 17:15' prior: 51654401! +sizeCodeForIf: encoder value: forValue + | thenExpr elseExpr branchSize thenSize elseSize | + thenExpr := arguments at: 1. + elseExpr := arguments at: 2. + (forValue + or: [(thenExpr isJust: NodeNil) + or: [elseExpr isJust: NodeNil]]) not + "(...not ifTrue: avoids using ifFalse: alone during this compile)" + ifTrue: "Two-armed IFs forEffect share a single pop" + [^super sizeCodeForEffect: encoder]. + forValue + ifTrue: "Code all forValue as two-armed" + [elseSize := elseExpr sizeCodeForEvaluatedValue: encoder. + thenSize := (thenExpr sizeCodeForEvaluatedValue: encoder) + + (thenExpr returns + ifTrue: [0] "Elide jump over else after a return" + ifFalse: [self sizeCode: encoder forJump: elseSize]). + branchSize := self sizeCode: encoder forBranchOn: false dist: thenSize] + ifFalse: "One arm is empty here (two-arms code forValue)" + [(elseExpr isJust: NodeNil) + ifTrue: + [elseSize := 0. + thenSize := thenExpr sizeCodeForEvaluatedEffect: encoder. + branchSize := self sizeCode: encoder forBranchOn: false dist: thenSize] + ifFalse: + [thenSize := 0. + elseSize := elseExpr sizeCodeForEvaluatedEffect: encoder. + branchSize := self sizeCode: encoder forBranchOn: true dist: elseSize]]. + sizes := Array with: thenSize with: elseSize. + ^(receiver sizeCodeForValue: encoder) + + branchSize + thenSize + elseSize! ! +!MessageNode methodsFor: 'code generation' stamp: 'eem 5/15/2008 09:57' prior: 51648771! +sizeCodeForIfNil: encoder value: forValue + + | theNode theSize theSelector | + equalNode := encoder encodeSelector: #==. + sizes := Array new: 1. + theNode := arguments first. + theSelector := #ifNotNil:. + forValue + ifTrue: + [sizes at: 1 put: (theSize := (encoder sizePop + (theNode sizeCodeForEvaluatedValue: encoder))). + ^(receiver sizeCodeForValue: encoder) + + encoder sizeDup + + (encoder sizePushSpecialLiteral: nil) + + (equalNode sizeCode: encoder args: 1 super: false) + + (self + sizeCode: encoder forBranchOn: selector key == theSelector + dist: theSize) + + theSize] + ifFalse: + [sizes at: 1 put: (theSize := (theNode sizeCodeForEvaluatedEffect: encoder)). + ^(receiver sizeCodeForValue: encoder) + + (encoder sizePushSpecialLiteral: nil) + + (equalNode sizeCode: encoder args: 1 super: false) + + (self + sizeCode: encoder + forBranchOn: selector key == theSelector + dist: theSize) + + theSize]! ! +!MessageNode methodsFor: 'code generation' stamp: 'eem 5/19/2008 15:09' prior: 51638274! +sizeCodeForToDo: encoder value: forValue + " var := rcvr. L1: [var <= arg1] Bfp(L2) [block body. var := var + inc] Jmp(L1) L2: " + | loopSize initStmt test block incStmt blockSize initSize limitInit | + block := arguments at: 3. + initStmt := arguments at: 4. + test := arguments at: 5. + incStmt := arguments at: 6. + limitInit := arguments at: 7. + initSize := initStmt sizeCodeForEffect: encoder. + limitInit == nil ifFalse: + [initSize := initSize + (limitInit sizeCodeForEffect: encoder)]. + blockSize := (block sizeCodeForEvaluatedEffect: encoder) + + (incStmt sizeCodeForEffect: encoder) + + (encoder sizeJumpLong: -1). + loopSize := (test sizeCodeForValue: encoder) + + (self sizeCode: encoder forBranchOn: false dist: blockSize) + + blockSize. + sizes := Array with: blockSize with: loopSize. + ^initSize + + loopSize + + (forValue ifTrue: [encoder sizePushSpecialLiteral: nil] ifFalse: [0])! ! +!MessageNode methodsFor: 'code generation' stamp: 'eem 8/15/2010 10:22' prior: 54017583! +sizeCodeForValue: encoder + | total | + special > 0 + ifTrue: [^self perform: (MacroSizers at: special) with: encoder with: true]. + receiver == NodeSuper + ifTrue: [selector := selector copy "only necess for splOops"]. + total := selector sizeCode: encoder args: arguments size super: receiver == NodeSuper. + receiver == nil + ifFalse: [total := total + (receiver sizeCodeForValue: encoder)]. + sizes := arguments collect: + [:arg | | argSize | + argSize := arg sizeCodeForValue: encoder. + total := total + argSize. + argSize]. + ^total! ! +!MessageNode methodsFor: 'code generation' stamp: 'eem 5/15/2008 10:00' prior: 51674780! +sizeCodeForWhile: encoder value: forValue + "L1: ... Bfp(L2) ... Jmp(L1) L2: nil (nil for value only); + justStmt, wholeLoop, justJump." + | cond stmt stmtSize loopSize branchSize | + cond := receiver. + stmt := arguments at: 1. + stmtSize := (stmt sizeCodeForEvaluatedEffect: encoder) + (encoder sizeJumpLong: 1). + branchSize := self + sizeCode: encoder + forBranchOn: selector key == #whileFalse: "Btp for whileFalse" + dist: stmtSize. + loopSize := (cond sizeCodeForEvaluatedValue: encoder) + branchSize + stmtSize. + sizes := Array with: stmtSize with: loopSize. + ^loopSize + (forValue ifTrue: [encoder sizePushSpecialLiteral: nil] ifFalse: [0])! ! +!MethodNode methodsFor: 'code generation (closures)' stamp: 'eem 5/29/2008 15:27'! +addLocalsToPool: locals "<Set of: TempVariableNode>" + localsPool isNil ifTrue: + [localsPool := IdentitySet new]. + localsPool addAll: locals! ! +!MethodNode methodsFor: 'debugger support' stamp: 'Igor.Stasenko 12/20/2009 03:59'! +blockExtentsToTempsMap + "Answer a Dictionary of blockExtent to temp locations for the current method. + This is used by the debugger to locate temp vars in contexts. A temp map + entry is a pair of the temp's name and its index, where an index is either an + integer for a normal temp or a pair of the index of the indirect temp vector + containing the temp and the index of the temp in its indirect temp vector." + + ^encoder blockExtentsToTempsMap ifNil: + [| methNode | + methNode := encoder classEncoding parserClass new + encoderClass: encoder class; + parse: (sourceText ifNil: [self decompileString]) + class: self methodClass. + "As a side effect generate: creates data needed for the map." + methNode generate. + methNode encoder blockExtentsToTempsMap]! ! +!MethodNode methodsFor: 'code generation (closures)' stamp: 'eem 7/24/2008 10:04'! +ensureClosureAnalysisDone + block blockExtent ifNil: + [temporaries := block analyseArguments: arguments temporaries: temporaries rootNode: self]! ! +!MethodNode methodsFor: 'code generation' stamp: 'eem 7/14/2010 11:28' prior: 51733588! +generate: trailer + "The receiver is the root of a parse tree. Answer a CompiledMethod. + The argument, trailer, is arbitrary but is typically either the reference + to the source code that is stored with every CompiledMethod, or an + encoding of the method's temporary names." + + | primErrNode blkSize nLits literals stack method | + self generate: trailer ifQuick: + [:m | + m literalAt: 2 put: encoder associationForClass; + properties: properties. + ^m]. + primErrNode := self primitiveErrorVariableName ifNotNil: + [encoder fixTemp: self primitiveErrorVariableName]. + encoder supportsClosureOpcodes ifTrue: + [self ensureClosureAnalysisDone. + encoder rootNode: self. "this is for BlockNode>>sizeCodeForClosureValue:"]. + blkSize := (block sizeCodeForEvaluatedValue: encoder) + + (primErrNode + ifNil: [0] + ifNotNil: [primErrNode sizeCodeForStore: encoder "The VM relies on storeIntoTemp: (129)"]). + method := CompiledMethod + newBytes: blkSize + trailerBytes: trailer + nArgs: arguments size + nTemps: (encoder supportsClosureOpcodes + ifTrue: [| locals | + locals := arguments, + temporaries, + (primErrNode + ifNil: [#()] + ifNotNil: [{primErrNode}]). + encoder + noteBlockExtent: block blockExtent + hasLocals: locals. + locals size] + ifFalse: [encoder maxTemp]) + nStack: 0 + nLits: (nLits := (literals := encoder allLiterals) size) + primitive: primitive. + nLits > 255 ifTrue: + [^self error: 'Too many literals referenced']. + 1 to: nLits do: [:lit | method literalAt: lit put: (literals at: lit)]. + encoder streamToMethod: method. + stack := ParseStack new init. + primErrNode ifNotNil: [primErrNode emitCodeForStore: stack encoder: encoder]. + stack position: method numTemps. + block emitCodeForEvaluatedValue: stack encoder: encoder. + stack position ~= (method numTemps + 1) ifTrue: + [^self error: 'Compiler stack discrepancy']. + encoder methodStreamPosition ~= (method size - trailer size) ifTrue: + [^self error: 'Compiler code size discrepancy']. + method needsFrameSize: stack size - method numTemps. + method properties: properties. + ^method! ! +!MethodNode methodsFor: 'code generation' stamp: 'Igor.Stasenko 12/20/2009 06:16'! +generateWithTempNames + "Answer a CompiledMethod with temps names encoded in trailer" + ^ self generate: (CompiledMethodTrailer new tempNames: self schematicTempNamesString). +! ! +!MethodNode methodsFor: 'debugger support' stamp: 'eem 7/1/2009 13:45'! +hasGeneratedMethod + ^encoder hasGeneratedMethod! ! +!MethodNode methodsFor: 'code generation (closures)' stamp: 'eem 5/20/2008 13:43'! +locationCounter + ^locationCounter! ! +!MethodNode methodsFor: 'code generation (closures)' stamp: 'eem 5/30/2008 11:27'! +noteBlockEntry: aBlock + "Evaluate aBlock with the numbering for the block entry." + locationCounter isNil ifTrue: + [locationCounter := -1]. + aBlock value: locationCounter + 1. + locationCounter := locationCounter + 2! ! +!MethodNode methodsFor: 'code generation (closures)' stamp: 'eem 6/2/2008 12:12'! +noteBlockExit: aBlock + "Evaluate aBlock with the numbering for the block exit." + aBlock value: locationCounter + 1. + locationCounter := locationCounter + 2! ! +!MethodNode methodsFor: 'printing' stamp: 'eem 8/15/2010 10:36' prior: 51737263! +printWithClosureAnalysisOn: aStream + self ensureClosureAnalysisDone. + precedence = 1 + ifTrue: + [(self selector includesSubString: '()/') + ifTrue: [aStream nextPutAll: (self selector copyUpTo: $)). + arguments + do: [:arg| aStream nextPutAll: arg key] + separatedBy: [aStream nextPutAll: ', ']. + aStream nextPut: $)] + ifFalse: [aStream nextPutAll: self selector]] "no node for method selector" + ifFalse: + [self selector keywords with: arguments do: + [:kwd :arg | + aStream nextPutAll: kwd; space. + arg printDefinitionForClosureAnalysisOn: aStream. + aStream space]]. + comment == nil ifFalse: + [aStream crtab: 1. + self printCommentOn: aStream indent: 1]. + temporaries size > 0 ifTrue: + [aStream crtab: 1; nextPut: $|. + temporaries do: [:temp | + aStream space. + temp printDefinitionForClosureAnalysisOn: aStream]. + aStream space; nextPut: $|]. + primitive > 0 ifTrue: + [(primitive between: 255 and: 519) ifFalse: "Dont decompile quick prims e.g, ^ self or ^instVar" + [aStream crtab: 1. + self printPrimitiveOn: aStream]]. + self printPropertiesOn: aStream. + self printPragmasOn: aStream. + aStream crtab: 1. + block printWithClosureAnalysisStatementsOn: aStream indent: 0! ! +!MethodNode methodsFor: 'code generation' stamp: 'eem 11/29/2008 18:53' prior: 23938335! +properties + ^properties! ! +!MethodNode methodsFor: 'code generation (closures)' stamp: 'eem 5/29/2008 16:07'! +referencedValuesWithinBlockExtent: anInterval + ^(localsPool select: + [:temp| + temp isReferencedWithinBlockExtent: anInterval]) collect: + [:temp| + temp isRemote ifTrue: [temp remoteNode] ifFalse: [temp]]! ! +!MethodNode methodsFor: 'debugger support' stamp: 'Igor.Stasenko 12/20/2009 03:58'! +schematicTempNamesString + "Answer the temp names for the current method node in a form that captures + temp structure. The temps at each method and block scope level occur + space-separated, with any indirect temps enclosed in parentheses. Each block + level is enclosed in square brackets. e.g. + 'method level temps (indirect temp)[block args and temps (indirect)]' + This representation can be reconstituted into a blockExtentsToTempsMap + by a CompiledMethod that has been copied with the schematicTempNamesString." + encoder hasGeneratedMethod ifFalse: + ["create the encoder's blockExtentsToLoals map, except if the method is quick + in which case it has no temps." + (self generate) isQuick ifTrue: + [^'']]. + ^encoder schematicTempNamesString! ! +!ParseNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 14:52' prior: 52069998! +emitCodeForBlockValue: stack encoder: encoder + "Generate code for evaluating the last statement in a block" + ^self emitCodeForValue: stack encoder: encoder! ! +!ParseNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 16:37' prior: 52069268! +emitCodeForBranchOn: condition dist: dist pop: stack encoder: encoder + stack pop: 1. + dist = 0 ifTrue: [^encoder genPop]. + condition + ifTrue: [encoder genBranchPopTrue: dist] + ifFalse: [encoder genBranchPopFalse: dist]! ! +!ParseNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 16:38' prior: 52066326! +emitCodeForEffect: stack encoder: encoder + + self emitCodeForValue: stack encoder: encoder. + encoder genPop. + stack pop: 1! ! +!ParseNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 16:39' prior: 52066948! +emitCodeForJump: dist encoder: encoder + + dist = 0 ifFalse: [encoder genJump: dist]! ! +!ParseNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 16:38' prior: 52066037! +emitCodeForReturn: stack encoder: encoder + + self emitCodeForValue: stack encoder: encoder. + encoder genReturnTop! ! +!ParseNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 17:13' prior: 52064750! +sizeCode: encoder forBranchOn: condition dist: dist + dist = 0 ifTrue: [^encoder sizePop]. + ^condition + ifTrue: [encoder sizeBranchPopTrue: dist] + ifFalse: [encoder sizeBranchPopFalse: dist]! ! +!ParseNode methodsFor: 'code generation' stamp: 'eem 5/15/2008 09:52' prior: 52067685! +sizeCode: encoder forJump: dist + + ^dist = 0 ifTrue: [0] ifFalse: [encoder sizeJump: dist]! ! +!ParseNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 14:52' prior: 52067118! +sizeCodeForBlockValue: encoder + "Answer the size for evaluating the last statement in a block" + ^self sizeCodeForValue: encoder! ! +!ParseNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 16:53' prior: 52066535! +sizeCodeForEffect: encoder + + ^(self sizeCodeForValue: encoder) + encoder sizePop! ! +!ParseNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 16:57' prior: 52069824! +sizeCodeForReturn: encoder + + ^(self sizeCodeForValue: encoder) + encoder sizeReturnTop! ! +!ReturnNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 16:40' prior: 52350839! +emitCodeForReturn: stack encoder: encoder + + expr emitCodeForReturn: stack encoder: encoder. + pc := encoder methodStreamPosition! ! +!ReturnNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 16:40' prior: 52350373! +emitCodeForValue: stack encoder: encoder + + expr emitCodeForReturn: stack encoder: encoder. + pc := encoder methodStreamPosition! ! +!ReturnNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 14:52' prior: 52349584! +sizeCodeForReturn: encoder + + ^expr sizeCodeForReturn: encoder! ! +!ReturnNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 14:52' prior: 52348629! +sizeCodeForValue: encoder + + ^expr sizeCodeForReturn: encoder! ! +!DecompilerConstructorForClosures methodsFor: 'constructor' stamp: 'eem 8/15/2010 16:56' prior: 50913929! +codeMethod: selector block: block tempVars: vars primitive: primitive class: class + + | blockNode selectorNode visibleTemps invisibleTemps arguments temporaries | + selectorNode := self codeSelector: selector code: nil. + tempVars := vars. + visibleTemps := OrderedCollection new. + invisibleTemps := OrderedCollection new. + tempVars do: [:t| + ((t isIndirectTempVector or: [t scope >= 0]) + ifTrue: [visibleTemps] + ifFalse: [invisibleTemps]) addLast: t]. + arguments := visibleTemps copyFrom: 1 to: nArgs. + temporaries := visibleTemps copyFrom: nArgs + 1 to: visibleTemps size. + block + arguments: arguments; + temporaries: temporaries. + blockNode := MethodNode new + selector: selectorNode + arguments: arguments + precedence: selector precedence + temporaries: temporaries + block: block + encoder: (EncoderForV3PlusClosures new initScopeAndLiteralTables + temps: visibleTemps, invisibleTemps + literals: literalValues + class: class) + primitive: primitive + properties: method properties copy. + blockNode properties method: blockNode. + ^blockNode! ! +!FutureNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 14:52' prior: 53916457! +emitCodeForBlockValue: stack encoder: encoder + "Generate code for evaluating the last statement in a block." + ^effectNode emitCodeForValue: stack encoder: encoder! ! +!FutureNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 14:52' prior: 53916708! +emitCodeForEffect: stack encoder: encoder + ^effectNode emitCodeForEffect: stack encoder: encoder! ! +!FutureNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 14:52' prior: 53916893! +emitCodeForValue: stack encoder: encoder + ^valueNode emitCodeForValue: stack encoder: encoder! ! +!FutureNode methodsFor: 'code generation' stamp: 'eem 7/18/2008 12:28' prior: 53918505! +sizeCodeForBlockValue: encoder + receiver == NodeSuper ifTrue: [^self error: 'Futures cannot send to future']. + (futureArgs isNil or: [futureSelector isNil]) ifTrue: + [^self error: 'Futures must be sent messages']. + encoder sharableLitIndex: originalSelector. "to find its senders" + futureDelta ifNil:[futureDelta := encoder encodeLiteral: 0]. + effectNode := MessageNode new + receiver: receiver + selector: #futureDo:at:args: + arguments: (Array + with: (encoder encodeLiteral: futureSelector) + with: futureDelta + with: (BraceNode new elements: futureArgs)) + precedence: 3 + from: encoder. + ^effectNode sizeCodeForValue: encoder! ! +!FutureNode methodsFor: 'code generation' stamp: 'eem 7/18/2008 12:27' prior: 53919232! +sizeCodeForEffect: encoder + receiver == NodeSuper ifTrue: [^self error: 'Futures cannot send to future']. + (futureArgs isNil or: [futureSelector isNil]) ifTrue: + [^self error: 'Futures must be sent messages']. + encoder sharableLitIndex: originalSelector. "to find its senders" + futureDelta ifNil:[futureDelta := encoder encodeLiteral: 0]. + effectNode := MessageNode new + receiver: receiver + selector: #futureDo:at:args: + arguments: (Array + with: (encoder encodeLiteral: futureSelector) + with: futureDelta + with: (BraceNode new elements: futureArgs)) + precedence: 3 + from: encoder. + ^effectNode sizeCodeForEffect: encoder! ! +!FutureNode methodsFor: 'code generation' stamp: 'eem 7/18/2008 12:28' prior: 53919956! +sizeCodeForValue: encoder + receiver == NodeSuper ifTrue: [^self error: 'Futures cannot send to future']. + (futureArgs isNil or: [futureSelector isNil]) ifTrue: + [^self error: 'Futures must be sent messages']. + encoder sharableLitIndex: originalSelector. "to find its senders" + futureDelta ifNil:[futureDelta := encoder encodeLiteral: 0]. + valueNode := MessageNode new + receiver: receiver + selector: #futureSend:at:args: + arguments: (Array + with: (encoder encodeLiteral: futureSelector) + with: futureDelta + with: (BraceNode new elements: futureArgs)) + precedence: 3 + from: encoder. + ^valueNode sizeCodeForValue: encoder! ! +!Encoder methodsFor: 'private' stamp: 'eem 8/13/2010 16:06'! +bindUndeclaredTemp: name + ^scopeTable at: name put: (self newUndeclaredTemp: name)! ! +!Encoder methodsFor: 'encoding' stamp: 'eem 8/15/2010 08:29'! +lookupVariable: name ifAbsent: aBlock + "Answer the binding of name in the scope table or aBlock's vaue if none. + Do not bind and do not lookup in pools. Used for correction, explanation etc" + ^scopeTable at: name ifAbsent: aBlock! ! +!Encoder methodsFor: 'temps' stamp: 'eem 8/14/2010 19:35'! +newUndeclaredTemp: name + ^UndeclaredVariableNode new name: name! ! +!Encoder methodsFor: 'results' stamp: 'eem 8/13/2010 16:51'! +undeclaredTemps + ^(scopeTable select: [:var | var isVariableNode and: [var isUndeclared]]) values! ! +!TempVariableNode methodsFor: 'code generation' stamp: 'eem 5/20/2008 16:22' prior: 52837966! +emitCodeForLoad: stack encoder: encoder + remoteNode ~~ nil ifTrue: + [remoteNode emitCodeForLoadFor: self stack: stack encoder: encoder]! ! +!TempVariableNode methodsFor: 'code generation' stamp: 'eem 5/20/2008 14:53' prior: 52847480! +emitCodeForStore: stack encoder: encoder + remoteNode ~~ nil ifTrue: + [^remoteNode emitCodeForStoreInto: self stack: stack encoder: encoder]. + encoder genStoreTemp: index! ! +!TempVariableNode methodsFor: 'code generation' stamp: 'eem 5/20/2008 14:54' prior: 52841122! +emitCodeForStorePop: stack encoder: encoder + remoteNode ~~ nil ifTrue: + [^remoteNode emitCodeForStorePopInto: self stack: stack encoder: encoder]. + encoder genStorePopTemp: index. + stack pop: 1! ! +!TempVariableNode methodsFor: 'code generation' stamp: 'eem 5/20/2008 14:53' prior: 52848137! +emitCodeForValue: stack encoder: encoder + remoteNode ~~ nil ifTrue: + [^remoteNode emitCodeForValueOf: self stack: stack encoder: encoder]. + encoder genPushTemp: index. + stack push: 1! ! +!TempVariableNode methodsFor: 'testing' stamp: 'eem 8/14/2010 11:02'! +isDeclaredAtMethodLevel + "For the explainer." + ^scope = 0! ! +!TempVariableNode methodsFor: 'code generation' stamp: 'eem 5/20/2008 16:23' prior: 52845581! +sizeCodeForLoad: encoder + ^remoteNode isNil + ifTrue: [0] + ifFalse: [remoteNode sizeCodeForLoadFor: self encoder: encoder]! ! +!TempVariableNode methodsFor: 'code generation' stamp: 'eem 5/20/2008 14:52' prior: 52838556! +sizeCodeForStore: encoder + remoteNode ~~ nil ifTrue: + [^remoteNode sizeCodeForStoreInto: self encoder: encoder]. + self reserve: encoder. + ^encoder sizeStoreTemp: index! ! +!TempVariableNode methodsFor: 'code generation' stamp: 'eem 5/20/2008 14:52' prior: 52847865! +sizeCodeForStorePop: encoder + remoteNode ~~ nil ifTrue: + [^remoteNode sizeCodeForStorePopInto: self encoder: encoder]. + self reserve: encoder. + ^encoder sizeStorePopTemp: index! ! +!TempVariableNode methodsFor: 'code generation' stamp: 'eem 5/20/2008 14:51' prior: 52844047! +sizeCodeForValue: encoder + remoteNode ~~ nil ifTrue: + [^remoteNode sizeCodeForValueOf: self encoder: encoder]. + self reserve: encoder. + ^encoder sizePushTemp: index! ! +!BraceNode methodsFor: 'code generation' stamp: 'eem 5/30/2008 17:40' prior: 50522406! +emitCodeForValue: stack encoder: encoder + + (encoder supportsClosureOpcodes + "Hack; we have no way of knowing how much stack space is available" + and: [elements size <= self maxElementsForConsArray]) ifTrue: + [elements do: [:node| node emitCodeForValue: stack encoder: encoder]. + encoder genPushConsArray: elements size. + stack + pop: elements size; + push: 1. + ^self]. + ^emitNode emitCodeForValue: stack encoder: encoder! ! +!BraceNode methodsFor: 'code generation' stamp: 'eem 5/30/2008 17:22' prior: 50516994! +sizeCodeForValue: encoder + + (encoder supportsClosureOpcodes + "Hack; we have no way of knowing how much stack space is available" + and: [elements size <= self maxElementsForConsArray]) ifTrue: + [^(elements inject: 0 into: [:sum :node| sum + (node sizeCodeForValue: encoder)]) + + (encoder sizePushConsArray: elements size)]. + emitNode := elements size <= 4 + ifTrue: ["Short form: Array braceWith: a with: b ... " + MessageNode 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" + CascadeNode new + receiver: (MessageNode new + receiver: (encoder encodeVariable: #Array) + selector: #braceStream: + arguments: (Array with: (encoder encodeLiteral: elements size)) + precedence: 3 from: encoder) + messages: ((elements collect: [:elt | MessageNode new receiver: nil + selector: #nextPut: + arguments: (Array with: elt) + precedence: 3 from: encoder]) + copyWith: (MessageNode new receiver: nil + selector: #braceArray + arguments: (Array new) + precedence: 1 from: encoder))]. + ^emitNode sizeCodeForValue: encoder! ! + +BytecodeAgnosticMethodNode removeSelector: #schematicTempNamesString! + +BytecodeAgnosticMethodNode removeSelector: #referencedValuesWithinBlockExtent:! + +BytecodeAgnosticMethodNode removeSelector: #printWithClosureAnalysisOn:! + +BytecodeAgnosticMethodNode removeSelector: #noteBlockExit:! + +BytecodeAgnosticMethodNode removeSelector: #noteBlockEntry:! + +BytecodeAgnosticMethodNode removeSelector: #locationCounter! + +BytecodeAgnosticMethodNode removeSelector: #hasGeneratedMethod! + +BytecodeAgnosticMethodNode removeSelector: #generateWithTempNames! + +BytecodeAgnosticMethodNode removeSelector: #generate:! + +BytecodeAgnosticMethodNode removeSelector: #ensureClosureAnalysisDone! + +BytecodeAgnosticMethodNode removeSelector: #blockExtentsToTempsMap! + +BytecodeAgnosticMethodNode removeSelector: #addLocalsToPool:! + +Smalltalk removeClassNamed: #BytecodeAgnosticMethodNode! + +MessageNode removeSelector: #sizeWhile:value:! + +MessageNode removeSelector: #sizeToDo:value:! + +MessageNode removeSelector: #sizeIfNil:value:! + +MessageNode removeSelector: #sizeIf:value:! + +MessageNode removeSelector: #sizeForValue:! + +MessageNode removeSelector: #sizeForEffect:! + +MessageNode removeSelector: #sizeCase:value:! + +MessageNode removeSelector: #emitWhile:on:value:! + +MessageNode removeSelector: #emitToDo:on:value:! + +MessageNode removeSelector: #emitIfNil:on:value:! + +MessageNode removeSelector: #emitIf:on:value:! + +MessageNode removeSelector: #emitForValue:on:! + +MessageNode removeSelector: #emitForEffect:on:! + +MessageNode removeSelector: #emitCase:on:value:! + +CascadeNode removeSelector: #sizeForValue:! + +CascadeNode removeSelector: #emitForValue:on:! + +FutureNode removeSelector: #sizeForValue:! + +FutureNode removeSelector: #sizeForEffect:! + +FutureNode removeSelector: #sizeForBlockValue:! + +FutureNode removeSelector: #emitForValue:on:! + +FutureNode removeSelector: #emitForEffect:on:! + +FutureNode removeSelector: #emitForBlockValue:on:! + +BytecodeEncoder removeSelector: #schematicTempNamesOn:blockExtents:fromIndex:! + +BytecodeEncoder removeSelector: #methodNodeClass! + +BraceNode removeSelector: #sizeForValue:! + +BraceNode removeSelector: #emitForValue:on:! + +TempVariableNode removeSelector: #cleanUpForRegeneration! + +LeafNode removeSelector: #sizeForValue:! + +LeafNode removeSelector: #sizeForEffect:! + +LeafNode removeSelector: #emitLong:on:! + +LeafNode removeSelector: #emitForEffect:on:! + +AssignmentNode removeSelector: #sizeForValue:! + +AssignmentNode removeSelector: #sizeForEffect:! + +AssignmentNode removeSelector: #emitForValue:on:! + +AssignmentNode removeSelector: #emitForEffect:on:! + +LiteralVariableNode removeSelector: #sizeForValue:! + +LiteralVariableNode removeSelector: #sizeForStorePop:! + +LiteralVariableNode removeSelector: #sizeForStore:! + +LiteralVariableNode removeSelector: #emitStorePop:on:! + +LiteralVariableNode removeSelector: #emitStore:on:! + +LiteralVariableNode removeSelector: #emitLoad:on:! + +LiteralVariableNode removeSelector: #emitForValue:on:! + +SelectorNode removeSelector: #size:args:super:! + +SelectorNode removeSelector: #emit:args:on:super:! + +SelectorNode removeSelector: #emit:args:on:! + +BlockNode removeSelector: #sizeForValue:! + +BlockNode removeSelector: #sizeForEvaluatedValue:! + +BlockNode removeSelector: #sizeForEvaluatedEffect:! + +BlockNode removeSelector: #sizeExceptLast:! + +BlockNode removeSelector: #emitForValue:on:! + +BlockNode removeSelector: #emitForEvaluatedValue:on:! + +BlockNode removeSelector: #emitForEvaluatedEffect:on:! + +BlockNode removeSelector: #emitExceptLast:on:! + +VariableNode removeSelector: #sizeForStorePop:! + +VariableNode removeSelector: #sizeForStore:! + +VariableNode removeSelector: #sizeForReturn:! + +VariableNode removeSelector: #emitStorePop:on:! + +VariableNode removeSelector: #emitStore:on:! + +VariableNode removeSelector: #emitLoad:on:! + +VariableNode removeSelector: #emitForValue:on:! + +VariableNode removeSelector: #emitForReturn:on:! + +ReturnNode removeSelector: #sizeForValue:! + +ReturnNode removeSelector: #sizeForReturn:! + +ReturnNode removeSelector: #emitForValue:on:! + +ReturnNode removeSelector: #emitForReturn:on:! + +LiteralNode removeSelector: #emitForValue:on:! + +ParseNode removeSelector: #sizeShortOrLong:! + +ParseNode removeSelector: #sizeJump:! + +ParseNode removeSelector: #sizeForReturn:! + +ParseNode removeSelector: #sizeForEffect:! + +ParseNode removeSelector: #sizeForBlockValue:! + +ParseNode removeSelector: #sizeBranchOn:dist:! + +ParseNode removeSelector: #emitShortOrLong:code:on:! + +ParseNode removeSelector: #emitLong:code:on:! + +ParseNode removeSelector: #emitJump:on:! + +ParseNode removeSelector: #emitForReturn:on:! + +ParseNode removeSelector: #emitForEffect:on:! + +ParseNode removeSelector: #emitForBlockValue:on:! + +ParseNode removeSelector: #emitBranchOn:dist:pop:on:! + +FieldNode removeSelector: #sizeForValue:! + +FieldNode removeSelector: #sizeForStorePop:! + +FieldNode removeSelector: #sizeForStore:! + +FieldNode removeSelector: #sizeForEffect:! + +FieldNode removeSelector: #emitStorePop:on:! + +FieldNode removeSelector: #emitStore:on:! + +FieldNode removeSelector: #emitLoad:on:! + +FieldNode removeSelector: #emitForValue:on:! + +FieldNode removeSelector: #emitForEffect:on:! +!FileStream class methodsFor: 'file reader services' stamp: 'ar 8/9/2010 10:46' prior: 35556199! +writeSourceCodeFrom: aStream baseName: baseName isSt: stOrCsFlag useHtml: useHtml + "Write the source code from aStream into a file. + Uses ChangeSet defaultChangeSetDirectory for consistency." + + ^(ChangeSet defaultChangeSetDirectory) + writeSourceCodeFrom: aStream + baseName: baseName + isSt: stOrCsFlag + useHtml: useHtml! ! +!FileDirectory methodsFor: 'utilities' stamp: 'ar 8/9/2010 10:44'! +writeSourceCodeFrom: aStream baseName: baseName isSt: stOrCsFlag useHtml: useHtml + "Write the source code from aStream into a file." + + | extension converter f fileName | + aStream contents isAsciiString ifTrue: [ + stOrCsFlag ifTrue: [ + extension := (FileDirectory dot, FileStream st). + ] ifFalse: [ + extension := (FileDirectory dot, FileStream cs). + ]. + converter := MacRomanTextConverter new. + ] ifFalse: [ + stOrCsFlag ifTrue: [ + extension := (FileDirectory dot, FileStream st "multiSt"). + ] ifFalse: [ + extension := (FileDirectory dot, FileStream cs "multiCs"). + ]. + converter := UTF8TextConverter new. + ]. + fileName := useHtml ifTrue: [baseName, '.html'] ifFalse: [baseName, extension]. + fileName := self checkName: fileName fixErrors: true. + f := self newFileNamed: fileName. + f ifNil: [^ self error: 'Cannot open file']. + (converter isMemberOf: UTF8TextConverter) + ifTrue: [f binary. + UTF8TextConverter writeBOMOn: f]. + f text. + f converter: converter. + f nextPutAll: aStream contents. + f close. +! ! + +"Files"! +!Rectangle commentStamp: 'nice 7/25/2010 14:56' prior: 27545885! +I represent a rectangular area of the screen. Arithmetic functions take points as arguments and carry out scaling and translating operations to create new instances of me. Rectangle functions create new instances by determining intersections of rectangles with rectangles. + +Note 1: only rectangles parallel to reference frame (Screen) can be represented by this class. + +Note 2: the Rectangle is represented by two extremities of one diagonal. By convention, it must be the diagonal: + from rectangle origin (the point having smallest coordinates in reference frame), + to rectangle corner (the point having largest coordinates in reference frame). + +Note 3: Screen coordinates conventions are: + x is horizontal axis, zero at left border, oriented toward right; + y is vertical axis, zero at top border, oriented toward bottom. +This corresponds to the latin convention for writing text from left to right and top to bottom. + +Note 4: the Rectangle extent is obtained by subtracting rectangle origin to rectangle corner coordinates. +If this leads to a negative width (extent x coordinate) and/or a negative height (extent y coordinate), then the Rectangle is degenerated and considered empty. + +Instance variables: + origin <Point> the coordinates of corner having smallest coordinates (top left in Screen coordinates) + corner <Point> the coordinates of corner having largest coordinates (bottom right in Screen coordinates) +! +!StrikeFont class methodsFor: 'examples' stamp: 'nice 8/19/2010 16:35' prior: 55662345! +readStrikeFont2Family: familyName fromDirectory: aDirectory + "StrikeFont readStrikeFont2Family: 'Lucida' fromDirectory: FileDirectory default" + "This utility reads all available .sf2 StrikeFont files for a given family from + the current directory. It returns an Array, sorted by size, suitable for handing + to TextStyle newFontArray: ." + "For this utility to work as is, the .sf2 files must be named 'familyNN.sf2'." + | fileNames strikeFonts | + fileNames := aDirectory fileNamesMatching: familyName , '##.sf2'. + strikeFonts := fileNames collect: [:fname | StrikeFont new readFromStrike2: fname]. + strikeFonts do: [ :font | font reset ]. + ^strikeFonts asArray sort: [:a :b | a height < b height]. + +"TextConstants at: #Lucida put: (TextStyle fontArray: (StrikeFont + readStrikeFont2Family: 'Lucida'))."! ! +!TextStyle methodsFor: 'fonts and font indexes' stamp: 'nice 8/19/2010 16:36' prior: 52976533! +addNewFontSize: pointSize + "Add a font in specified size to the array of fonts." + | f d newArray t isSet | + fontArray first emphasis ~= 0 ifTrue: [ + t := TextConstants at: self fontArray first familyName asSymbol. + t fonts first emphasis = 0 ifTrue: [ + ^ t addNewFontSize: pointSize. + ]. + ]. + + pointSize <= 0 ifTrue: [^ nil]. + fontArray do: [:s | + s pointSize = pointSize ifTrue: [^ s]. + ]. + + (isSet := fontArray first isKindOf: TTCFontSet) + ifTrue:[ + | fonts | + fonts := fontArray first fontArray collect: [ :font | + | newFont | + (font isNil) + ifTrue: [newFont := nil] + ifFalse: [ + newFont := (font ttcDescription size > 256) + ifTrue: [MultiTTCFont new initialize] + ifFalse: [TTCFont new initialize]. + newFont ttcDescription: font ttcDescription. + newFont pixelSize: pointSize * 96 // 72. + font derivativeFonts notEmpty ifTrue: [font derivativeFonts do: [ :proto | + proto ifNotNil: [ + d := proto class new initialize. + d ttcDescription: proto ttcDescription. + d pixelSize: newFont pixelSize. + newFont derivativeFont: d]]]. + ]. + newFont]. + f := TTCFontSet newFontArray: fonts] + ifFalse: [ + f := fontArray first class new initialize: fontArray first. + f pointSize: pointSize. + fontArray first derivativeFonts do: [:proto | + proto ifNotNil: [ + d := proto class new initialize: proto. + d pointSize: f pointSize. + f derivativeFont: d mainFont: proto. + ]. + ]. + ]. + newArray := (fontArray copyWith: f) asArray sort: [:a :b | a pointSize <= b pointSize]. + self newFontArray: newArray. + isSet ifTrue: [ + TTCFontSet register: newArray at: newArray first familyName asSymbol. + ]. + ^ self fontOfPointSize: pointSize +! ! +!Rectangle methodsFor: 'transforming' stamp: 'nice 6/20/2010 21:27' prior: 27567474! +flipBy: direction centerAt: aPoint + "Return a copy flipped #vertical or #horizontal, about aPoint." + | futureOrigin futureCorner | + direction == #horizontal + ifTrue: + [futureOrigin := self topRight. + futureCorner := self bottomLeft] + ifFalse: [direction == #vertical + ifTrue: + [futureOrigin := self bottomLeft. + futureCorner := self topRight] + ifFalse: [self error: 'unrecognizable direction']]. + ^ (futureOrigin flipBy: direction centerAt: aPoint) + corner: (futureCorner flipBy: direction centerAt: aPoint)! ! +!Rectangle methodsFor: 'testing' stamp: 'nice 6/20/2010 21:32' prior: 52271353! +intersects: aRectangle + "Answer whether aRectangle intersects the receiver anywhere." + "Optimized; old code answered: + (origin max: aRectangle origin) < (corner min: aRectangle corner)" + + | rOrigin rCorner | + rOrigin := aRectangle origin. + rCorner := aRectangle corner. + rCorner x <= origin x ifTrue: [^ false]. + rCorner y <= origin y ifTrue: [^ false]. + rOrigin x >= corner x ifTrue: [^ false]. + rOrigin y >= corner y ifTrue: [^ false]. +"None of the two rectangle shall be empty" + corner x <= origin x ifTrue: [^ false]. + corner y <= origin y ifTrue: [^ false]. + rCorner x <= rOrigin x ifTrue: [^ false]. + rCorner y <= rOrigin y ifTrue: [^ false]. + ^ true +! ! +!Rectangle methodsFor: 'transforming' stamp: 'nice 6/20/2010 22:01' prior: 27570080! +rotateBy: direction centerAt: aPoint + "Return a copy rotated #right, #left, or #pi about aPoint" + | futureOrigin futureCorner | + direction == #pi + ifTrue: + [futureOrigin := self corner. + futureCorner := self origin] + ifFalse: [direction == #left + ifTrue: + [futureOrigin := self topRight. + futureCorner := self bottomLeft] + ifFalse: [direction == #right + ifTrue: + [futureOrigin := self bottomLeft. + futureCorner := self topRight] + ifFalse: [self error: 'unrecognizable direction']]]. + ^ (futureOrigin rotateBy: direction centerAt: aPoint) + corner: (futureCorner rotateBy: direction centerAt: aPoint)! ! +!Project commentStamp: 'cbr 7/27/2010 21:36' prior: 36989659! +A Project stores the state of a complete Squeak desktop, including +the windows, and the currently active changeSet. A project knows who +its parent project is. When you change projects, whether by entering +or exiting, the screen state of the project being exited is saved in +that project. + +A project is retained by its view in the parent world. It is +effectively named by the name of its changeSet, which can be changed +either by renaming in a changeSorter, or by editing the label of its +view from the parent project. + +As the site of major context switch, Projects are the locus of +swapping between the old MVC and the new Morphic worlds. The +distinction is based on whether the variable 'world' contains a +WorldMorph or a ControlManager. + +Saving and Loading +Projects may be stored on the disk in external format. (Project +named: 'xxx') exportSegment, or choose 'store project on file...'. +Projects may be loaded from a server and stored back. Storing on a +server never overwrites; it always makes a new version. A project +remembers the url of where it lives in urlList. The list is length +one, for now. The url may point to a local disk instead of a server. +All projects that the user looks at are cached in the Squeaklet +folder. Sorted by server. The cache holds the most recent version +only. + +When a project is loaded into Squeak, its objects are converted to +the current version. There are three levels of conversion. First, +each object is converted from raw bits to an object in its old +format. Then it is sent some or all of these messages: + comeFullyUpOnReload: smartRefStream Used to +re-discover an object that already exists in this image, such as a +resource, global variable, Character, or Symbol. (sent to objects in +outPointers) + convertToCurrentVersion: varDict refStream: smartRefStrm + fill in fields that have been added to a class since +the object was stored. Used to set the extra inst var to a default +value. Or, return a new object of a different class. (sent to +objects that changed instance variables) + fixUponLoad: aProject refStream: smartRefStrm + change the object due to conventions that have changed on the +project level. (sent to all objects in the incoming project) + +Here is the calling sequence for storing out a Project: +Project saveAs +Project storeOnServer +Project storeOnServerWithProgressInfo +Project storeOnServerInnards +Project exportSegmentFileName:directory: +Project exportSegmentWithChangeSet:fileName:directory: +ImageSegment writeForExportWithSources:inDirectory:changeSet: + +! +!MethodReference methodsFor: 'queries' stamp: 'eem 5/25/2010 17:56'! +selector + + ^methodSymbol! ! +!SystemNavigation methodsFor: 'browse' stamp: 'dtl 8/1/2010 10:12'! +browseMyChanges + "Browse only the changes (in the changes file) by the current author." + + "SystemNavigation default browseMyChanges" + + self browseAllSelect: [ :method | + method fileIndex > 1 "only look at changes file" + and: [ method timeStamp beginsWith: Utilities authorInitials ]]! ! +!ChangeSet methodsFor: 'fileIn/Out' stamp: 'ar 8/9/2010 10:47' prior: 54154921! +fileOut + "File out the receiver, to a file whose name is a function of the + change-set name and either of the date & time or chosen to have a + unique numeric tag, depending on the preference + 'changeSetVersionNumbers'" + | slips nameToUse | + self checkForConversionMethods. + ChangeSet promptForDefaultChangeSetDirectoryIfNecessary. + nameToUse := Preferences changeSetVersionNumbers + ifTrue: [self defaultChangeSetDirectory nextNameFor: self name extension: FileStream cs] + ifFalse: [self name , FileDirectory dot , Utilities dateTimeSuffix, FileDirectory dot , FileStream cs]. + Cursor write showWhile: [ | internalStream | + internalStream := WriteStream on: (String new: 10000). + internalStream header; timeStamp. + self fileOutPreambleOn: internalStream. + self fileOutOn: internalStream. + self fileOutPostscriptOn: internalStream. + internalStream trailer. + + FileStream writeSourceCodeFrom: internalStream baseName: (nameToUse copyFrom: 1 to: nameToUse size - 3) isSt: false useHtml: false. + ]. + Preferences checkForSlips + ifFalse: [^ self]. + slips := self checkForSlips. + (slips size > 0 + and: [(UIManager default chooseFrom: #('Ignore' 'Browse slips') + title: 'Methods in this fileOut have halts +or references to the Transcript +or other ''slips'' in them. +Would you like to browse them?') + = 2]) + ifTrue: [self systemNavigation browseMessageList: slips name: 'Possible slips in ' , name]! ! +!ChangeRecord methodsFor: 'access' stamp: 'eem 8/14/2010 20:35' prior: 34377361! +methodClass + | methodClassName methodClass | + (#(method #classComment) includes: type) ifFalse: [ ^ nil ]. + methodClassName := class subStrings + ifEmpty: [ ^ nil ] + ifNotEmptyDo: + [ : parts | parts first asSymbol ]. + (Smalltalk globals includesKey: methodClassName) ifFalse: [ ^ nil ]. + methodClass := Smalltalk at: methodClassName. + ^ meta + ifTrue: [ methodClass class ] + ifFalse: [ methodClass ]! ! +!SystemOrganizer methodsFor: 'fileIn/Out' stamp: 'nice 8/19/2010 16:35' prior: 52747662! +orderedTraitsIn: category + "Answer an OrderedCollection containing references to the traits in the + category whose name is the argument, category (a string). The traits + are ordered so they can be filed in." + + | behaviors traits | + behaviors := (self listAtCategoryNamed: category asSymbol) + collect: [:title | Smalltalk at: title]. + traits := behaviors reject: [:each | each isBehavior]. + ^traits asArray sort: [:t1 :t2 | + (t2 traitComposition allTraits includes: t1) + or: [(t1 traitComposition allTraits includes: t2) not]]! ! +!TheWorldMainDockingBar methodsFor: 'submenu - apps' stamp: 'ar 8/6/2010 23:40'! +appsMenuOn: aDockingBar + "Create a menu with the registered apps" + + aDockingBar addItem: [ :item | + item + contents: 'Apps' translated; + subMenuUpdater: self + selector: #listAppsOn: ] +! ! +!TheWorldMainDockingBar methodsFor: 'submenu - apps' stamp: 'ar 8/6/2010 23:44'! +listAppsOn: menu + "Update the apps list in the menu" + + | args | + TheWorldMenu registeredOpenCommands do:[:spec| + args := spec second. + menu addItem: [ :item | + item + contents: spec first translated; + target: args first; + selector: args second]. + ]. +! ! +!TheWorldMainDockingBar methodsFor: 'construction' stamp: 'ar 8/6/2010 23:45' prior: 59056125! +menusOn: aDockingBar + + self + squeakMenuOn: aDockingBar; + projectsMenuOn: aDockingBar; + toolsMenuOn: aDockingBar; + appsMenuOn: aDockingBar; + extrasMenuOn: aDockingBar; + windowsMenuOn: aDockingBar; + helpMenuOn: aDockingBar. + aDockingBar addSpacer. + self + searchBarOn: aDockingBar; + clockOn: aDockingBar! ! +!TextEditor methodsFor: 'explain' stamp: 'eem 8/14/2010 11:15' prior: 57293992! +explainTemp: string + "Is string the name of a temporary variable (method or block argument or temporary)?" + + | selectedClass methodNode tempNode | + (model respondsTo: #selectedMessageName) ifFalse: [^ nil]. + model selectedMessageName ifNil: [^nil]. "not in a method" + selectedClass := model selectedClassOrMetaClass. + methodNode := selectedClass parserClass new parse: model selectedMessage class: selectedClass. + tempNode := methodNode encoder tempNodes detect: [:n| n name = string] ifNone: [^nil]. + ^(tempNode isArg + ifTrue: ['"is an argument to this '] + ifFalse: ['"is a temporary variable in this ']), + (tempNode isDeclaredAtMethodLevel + ifTrue: ['method"'] + ifFalse: ['block"'])! ! +!SketchMorph methodsFor: 'menu' stamp: 'cmm 8/2/2010 18:09' prior: 52549432! +erasePixelsOfColor: aColor + "Let the user specifiy a color such that all pixels of that color should be erased; then do the erasure" + | newBounds | + originalForm + mapColor: aColor + to: Color transparent. + newBounds := originalForm rectangleEnclosingPixelsNotOfColor: Color transparent. + self form: (originalForm copy: newBounds)! ! +!SketchMorph methodsFor: 'menu' stamp: 'cmm 8/2/2010 18:19'! +erasePixelsUsing: evt + "Let the user specifiy a color such that all pixels of that color should be erased; then do the erasure" + self + changeColorTarget: self + selector: #rememberedColor: + originalColor: nil + hand: evt hand. + self rememberedColor "color to erase" + ifNil: [ ^ self ] + ifNotNilDo: + [ : chosenColor | self erasePixelsOfColor: chosenColor ]! ! +!SketchMorph methodsFor: 'menu' stamp: 'cmm 8/2/2010 18:15'! +recolorPixelsOfColor: originalColor with: newColor + "Let the user select a color to be remapped, and then a color to map that color to, then carry it out." + | d newForm map | + d := originalForm depth. + newForm := Form extent: originalForm extent depth: d. + map := (Color cachedColormapFrom: d to: d) copy. + map at: (originalColor indexInMap: map) put: (newColor pixelValueForDepth: d). + newForm copyBits: newForm boundingBox + from: originalForm at: 0@0 + colorMap: map. + self form: newForm. +! ! +!SketchMorph methodsFor: 'menu' stamp: 'cmm 8/2/2010 18:18'! +recolorPixelsUsing: evt + "Let the user select a color to be remapped, and then a color to map that color to, then carry it out." + | originalColor newColor | + self inform: 'choose the color you want to replace' translated. + self + changeColorTarget: self + selector: #rememberedColor: + originalColor: nil + hand: evt hand. + "color to replace" + originalColor := self rememberedColor ifNil: [ ^ self ]. + self inform: 'now choose the color you want to replace it with' translated. + self + changeColorTarget: self + selector: #rememberedColor: + originalColor: originalColor + hand: evt hand. + "new color" + newColor := self rememberedColor ifNil: [ ^ self ]. + self + recolorPixelsOfColor: originalColor + with: newColor! ! +!TheWorldMenu methodsFor: 'construction' stamp: 'ar 8/2/2010 20:51' prior: 52991136! +addPrintAndDebug: menu + Preferences simpleMenus ifFalse: [ + self + fillIn: menu + from: { + { 'make screenshot'. {self. #saveScreenshot}. 'makes a screenshot and saves it to disk'}. + "{ 'print PS to file...'. { self. #printWorldOnFile }. 'write the world into a postscript file' }." + { 'debug...'. { self. #debugDo }. 'a menu of debugging items' } + } ]! ! +!TheWorldMenu methodsFor: 'action' stamp: 'ar 8/2/2010 20:51'! +saveScreenshot + "Make a screenshot of the world and save it to a file" + + SampledSound playSoundNamed: 'camera'. + PNGReadWriter putForm: myWorld imageForm onFileNamed: + (FileDirectory default nextNameFor: 'SqueakScreen' extension:'png'). +! ! +!HaloMorph methodsFor: 'handles' stamp: 'sw 3/30/2005 04:26'! +doDupOrMakeSibling: evt with: dupHandle + "Ask hand to duplicate my target, if shift key *not* pressed, or make a sibling if shift key *is* pressed" + + ^ (evt shiftPressed and: [target couldMakeSibling]) + ifTrue: + [dupHandle color: Color green muchDarker. + self doMakeSibling: evt with: dupHandle] + ifFalse: + [self doDup: evt with: dupHandle]! ! +!HaloMorph methodsFor: 'handles' stamp: 'sw 3/30/2005 04:28'! +doMakeSiblingOrDup: evt with: dupHandle + "Ask hand to duplicate my target, if shift key *is* pressed, or make a sibling if shift key *not* pressed" + + ^ (evt shiftPressed or: [target couldMakeSibling not]) + ifFalse: + [self doMakeSibling: evt with: dupHandle] + ifTrue: + [dupHandle color: Color green. + self doDup: evt with: dupHandle]! ! +!Morph methodsFor: 'menus' stamp: 'cmm 8/2/2010 18:20' prior: 24277159! +addPaintingItemsTo: aMenu hand: aHandMorph + | subMenu movies | + subMenu := MenuMorph new defaultTarget: self. + subMenu add: 'repaint' translated action: #editDrawing. + subMenu add: 'set rotation center' translated action: #setRotationCenter. + subMenu add: 'reset forward-direction' translated + action: #resetForwardDirection. + subMenu add: 'set rotation style' translated action: #setRotationStyle. + subMenu add: 'erase pixels of color' translated + action: #erasePixelsUsing:. + subMenu add: 'recolor pixels of color' translated + action: #recolorPixelsUsing:. + subMenu add: 'reduce color palette' translated action: #reduceColorPalette:. + subMenu add: 'add a border around this shape...' translated + action: #addBorderToShape:. + movies := (self world rootMorphsAt: aHandMorph targetPoint) + select: [:m | (m isKindOf: MovieMorph) or: [m isSketchMorph]]. + movies size > 1 + ifTrue: + [subMenu add: 'insert into movie' translated action: #insertIntoMovie:]. + aMenu add: 'painting...' translated subMenu: subMenu! ! + +SketchMorph removeSelector: #recolorPixelsOfColor:! + +"Morphic"! +!LedCharacterMorph commentStamp: 'cbr 7/27/2010 18:47' prior: 59337038! +I represent a character to be displayed on an LedMorph; I am a peer to LedDigitMorph. The char 36 is SPACE. + +I can live outside of LedMorphs, however. If you'd like to play with me, evaluate the following line: + + +LedCharacterMorph new char: $e; openInWorld! +!WaveEditor methodsFor: 'other' stamp: 'nice 8/19/2010 21:27' prior: 33108605! +findPossibleLoopStartsFrom: index + "Assume loopEnd is one sample before a zero-crossing." + + | r postLoopCycleStart i postLoopCycleLength cycleLength cycleCount err oldI | + r := OrderedCollection new. + + "Record the start and length of the first cycle after the loop endpoint." + postLoopCycleStart := loopEnd + 1. "Assumed to be a zero-crossing." + i := self zeroCrossingAfter: postLoopCycleStart + + (0.9 * samplingRate / perceivedFrequency) asInteger. + postLoopCycleLength := i - loopEnd - 1. + + "Step backwards one cycle at a time, using zero-crossings to find the + beginning of each cycle, and record the auto-corrolation error between + each cycle and the cycle following the loop endpoint. Assume pitch may shift gradually." + i := self zeroCrossingAfter: postLoopCycleStart + - (1.1 * postLoopCycleLength) asInteger. + cycleLength := postLoopCycleStart - i. + cycleCount := 1. + [cycleLength > 0] whileTrue: + [err := self + autoCorrolationBetween: i + and: postLoopCycleStart + length: postLoopCycleLength. + r add: (Array + with: i + with: err + with: cycleCount + with: ((loopEnd - i) asFloat / self samplingRate roundTo: 0.01)). + oldI := i. + i := self zeroCrossingAfter: oldI - (1.1 * cycleLength) asInteger. + cycleLength := oldI - i. "will be zero when start of data is encountered" + cycleCount := cycleCount + 1]. + ^r asArray sort: [:e1 :e2 | e1 second < e2 second]! ! + +"MorphicExtras"! +!SocketStream methodsFor: 'initialize-release' stamp: 'ar 7/24/2010 15:13'! +destroy + "Destroy the receiver and its underlying socket. Does not attempt to flush the output buffers. For a graceful close use SocketStream>>close instead." + + socket ifNotNil:[socket destroy]! ! +!SocketStream methodsFor: 'control' stamp: 'ar 7/24/2010 14:48' prior: 52619090! +flush + "If the other end is connected and we have something + to send, then we send it and reset the outBuffer." + + ((outNextToWrite > 1) and: [socket isOtherEndClosed not]) + ifTrue: [ + [self sendData: outBuffer count: outNextToWrite - 1] + on: ConnectionTimedOut + do: [:ex | shouldSignal ifFalse: ["swallow"]]. + outNextToWrite := 1]! ! +!SocketStream methodsFor: 'testing' stamp: 'ar 7/24/2010 14:50' prior: 29500464! +isDataAvailable + "Answer if more data can be read. It the inbuffer is empty, we check the socket for data. If it claims to have data available to read, we try to read some once and recursively call this method again. If something really was available it is now in the inBuffer. This is because there has been spurious dataAvailable when there really is no data to get. + + Note: Some subclasses (such as SecureSocketStream) rely on the behavior here since even though data may be available in the underlying socket, it may not result in any output (yet)." + + self isInBufferEmpty ifFalse: [^true]. + ^socket dataAvailable + ifFalse: [false] + ifTrue: [self receiveAvailableData; isDataAvailable]! ! +!SocketStream methodsFor: 'stream out' stamp: 'ar 7/24/2010 14:48' prior: 52611609! +nextPutAllFlush: aCollection + "Put a String or a ByteArray onto the stream. + You can use this if you have very large data - it avoids + copying into the buffer (and avoids buffer growing) + and also flushes any other pending data first." + + | toPut | + toPut := binary ifTrue: [aCollection asByteArray] ifFalse: [aCollection asString]. + self flush. "first flush pending stuff, then directly send" + socket isOtherEndClosed ifFalse: [ + [self sendData: toPut count: toPut size] + on: ConnectionTimedOut + do: [:ex | shouldSignal ifFalse: ["swallow"]]]! ! +!SocketStream methodsFor: 'private-socket' stamp: 'ar 7/24/2010 15:07' prior: 52610836! +receiveAvailableData + "Receive available data (as much as fits in the inBuffer) but not waiting for more to arrive. Return the position in the buffer where the new data starts, regardless if anything was read, see #adjustInBuffer." + + recentlyRead := self receiveDataInto: inBuffer startingAt: inNextToWrite. + ^self adjustInBuffer: recentlyRead! ! +!SocketStream methodsFor: 'private-socket' stamp: 'ar 7/24/2010 15:03' prior: 29504781! +receiveData + "Receive data. Signal exceptions and timeouts depending on #shouldSignal and #shouldTimeout. Return the position in the buffer where the new data starts, regardless if anything was read." + + socket + waitForDataFor: self timeout + ifClosed: [self shouldSignal + ifTrue:[ConnectionClosed signal: 'Connection closed while waiting for data.']] + ifTimedOut: [self shouldTimeout + ifTrue:[ConnectionTimedOut signal: 'Data receive timed out.']]. + ^self receiveAvailableData! ! +!SocketStream methodsFor: 'control' stamp: 'ar 8/5/2010 12:23' prior: 29486984! +receiveData: nBytes + "Keep reading the socket until we have nBytes + in the inBuffer or we reach the end. This method + does not return data, but can be used to make sure + data has been read into the buffer from the Socket + before actually reading it from the FastSocketStream. + Mainly used internally. We could also adjust the buffer + to the expected amount of data and avoiding several + incremental grow operations. + + NOTE: This method doesn't honor timeouts if shouldSignal + is false!! And frankly, I am not sure how to handle that + case or if I care - I think we should always signal." + + [self isConnected and: [nBytes > self inBufferSize]] + whileTrue: [self receiveData]! ! +!SocketStream methodsFor: 'private-socket' stamp: 'ar 7/24/2010 14:50' prior: 52617013! +receiveDataIfAvailable + "Deprecated. Use #receiveAvailableData instead" + + ^self receiveAvailableData! ! +!SocketStream methodsFor: 'private-socket' stamp: 'ar 7/24/2010 15:07'! +receiveDataInto: buffer startingAt: index. + "Read data from the underlying socket. This method may be overridden by subclasses wanting to control incoming traffic for other purposes like encryption or statistics." + + ^socket receiveAvailableDataInto: buffer startingAt: index.! ! +!SocketStream methodsFor: 'private-socket' stamp: 'ar 7/24/2010 14:50'! +sendData: buffer count: n + "Sends outgoing data directly on the underlying socket." + + ^socket sendData: buffer count: n! ! +!SocketStream methodsFor: 'stream in' stamp: 'ar 8/2/2010 18:50' prior: 52619519! +upTo: aCharacterOrByte + "Answer a subcollection from the current access position to the occurrence (if any, but not inclusive) of anObject in the receiver. If anObject is not in the collection, answer the entire rest of the receiver." + + "Note: The 100k limit below is compatible with the previous version though arguably incorrect. If you need unbounded behavior either up the argument or provide nil in which case we'll read until we get it or run out of memory" + + ^self upTo: aCharacterOrByte limit: 100000! ! +!SocketStream methodsFor: 'stream in' stamp: 'ar 8/2/2010 18:50'! +upTo: aCharacterOrByte limit: nBytes + "Return data up to, but not including given character or byte. If the character is not in the stream, or not found within nBytes answer the available contents of the stream" + + | index result searchedSoFar | + "Look in the current inBuffer first" + index := inBuffer indexOf: aCharacterOrByte startingAt: lastRead + 1. + + (index > 0 and: [(index + 1) <= inNextToWrite]) ifTrue: ["found it" + result := self nextInBuffer: index - lastRead - 1. + self skip: 1. + ^ result + ]. + + [searchedSoFar := self inBufferSize. + "Receive more data" + self receiveData. + "We only get recentlyRead = 0 in the case of a non-signaling socket close." + recentlyRead > 0] whileTrue:[ + "Data begins at lastRead + 1, we add searchedSoFar as offset." + + index := inBuffer indexOf: aCharacterOrByte + startingAt: (lastRead + searchedSoFar + 1). + (index > 0 and: [(index + 1) <= inNextToWrite]) ifTrue: ["found it" + result := self nextInBuffer: index - lastRead - 1. + self skip: 1. + ^ result + ]. + + "Check if we've exceeded the max. amount" + (nBytes notNil and:[inNextToWrite - lastRead > nBytes]) + ifTrue:[^self nextAllInBuffer]. + ]. + + "not found and (non-signaling) connection was closed" + ^self nextAllInBuffer! ! +!SocketStream methodsFor: 'stream in' stamp: 'ar 8/2/2010 18:48' prior: 52614582! +upToAll: aStringOrByteArray + "Answer a subcollection from the current access position to the occurrence (if any, but not inclusive) of aCollection. If aCollection is not in the stream, answer the entire rest of the stream." + + "Note: The 100k limit below is compatible with the previous version though arguably incorrect. If you need unbounded behavior either up the argument or provide nil in which case we'll read until we get it or run out of memory" + + ^self upToAll: aStringOrByteArray limit: 100000! ! +!SocketStream methodsFor: 'stream in' stamp: 'ar 8/2/2010 18:50'! +upToAll: aStringOrByteArray limit: nBytes + "Answer a subcollection from the current access position to the occurrence (if any, but not inclusive) of aStringOrByteArray. If aCollection is not in the stream, or not found within nBytes answer the available contents of the stream" + + | index sz result searchedSoFar | + sz := aStringOrByteArray size. + "Look in the current inBuffer first" + index := inBuffer indexOfSubCollection: aStringOrByteArray + startingAt: lastRead - sz + 2. + (index > 0 and: [(index + sz) <= inNextToWrite]) ifTrue: ["found it" + result := self nextInBuffer: index - lastRead - 1. + self skip: sz. + ^ result + ]. + + [searchedSoFar := self inBufferSize. + "Receive more data" + self receiveData. + recentlyRead > 0] whileTrue:[ + + "Data begins at lastRead + 1, we add searchedSoFar as offset and + backs up sz - 1 so that we can catch any borderline hits." + + index := inBuffer indexOfSubCollection: aStringOrByteArray + startingAt: (lastRead + searchedSoFar - sz + 2 max: 1). + (index > 0 and: [(index + sz) <= inNextToWrite]) ifTrue: ["found it" + result := self nextInBuffer: index - lastRead - 1. + self skip: sz. + ^ result + ]. + "Check if we've exceeded the max. amount" + (nBytes notNil and:[inNextToWrite - lastRead > nBytes]) + ifTrue:[^self nextAllInBuffer]. + ]. + + "not found and (non-signaling) connection was closed" + ^self nextAllInBuffer! ! +!SocketStream methodsFor: 'stream in' stamp: 'ar 8/5/2010 12:23' prior: 29497260! +upToEnd + "Answer all data coming in on the socket until the socket + is closed by the other end, or we get a timeout. + This means this method catches ConnectionClosed by itself. + + NOTE: Does not honour timeouts if shouldSignal is false!!" + + [[self isConnected] whileTrue: [self receiveData]] + on: ConnectionClosed + do: [:ex | "swallow it"]. + ^self nextAllInBuffer! ! + +"Network"! +!SampledInstrument methodsFor: 'other' stamp: 'nice 8/19/2010 16:34' prior: 28103941! +allNotes + "Answer a collection containing of all the unique sampled sounds used by this instrument." + + | r | + r := IdentitySet new. + r addAll: sustainedLoud. + sustainedSoft ~~ sustainedLoud ifTrue: [r addAll: sustainedSoft]. + staccatoLoud ~~ sustainedLoud ifTrue: [r addAll: staccatoLoud]. + staccatoSoft ~~ staccatoLoud ifTrue: [r addAll: staccatoSoft]. + ^ r asArray sort: [:n1 :n2 | n1 pitch < n2 pitch] +! ! +!FFT methodsFor: 'bulk processing' stamp: 'ul 8/3/2010 15:43' prior: 20330288! +transformDataFrom: anIndexableCollection startingAt: index + "Forward transform a block of real data taken from from the given indexable collection starting at the given index. Answer a block of values representing the normalized magnitudes of the frequency components." + + | j real imag out | + j := 0. + index to: index + n - 1 do: [:i | + realData at: (j := j + 1) put: (anIndexableCollection at: i)]. + realData *= window. + imagData := FloatArray new: n. + self transformForward: true. + + "compute the magnitudes of the complex results" + "note: the results are in bottom half; the upper half is just its mirror image" + real := realData copyFrom: 1 to: (n / 2). + imag := imagData copyFrom: 1 to: (n / 2). + out := (real * real) + (imag * imag). + 1 to: out size do: [:i | out at: i put: (out at: i) sqrt]. + ^ out +! ! +!FFT methodsFor: 'transforming' stamp: 'ul 8/3/2010 15:43' prior: 20336130! +transformForward: forward + | lev lev1 ip theta realU imagU realT imagT i | + <primitive: 'primitiveFFTTransformData' module: 'FFTPlugin'> + self permuteData. + 1 to: nu do: + [:level | + lev := 1 bitShift: level. + lev1 := lev // 2. + 1 to: lev1 do: + [:j | + theta := j-1 * (n // lev). "pi * (j-1) / lev1 mapped onto 0..n/2" + theta < (n//4) "Compute U, the complex multiplier for each level" + ifTrue: + [realU := sinTable at: sinTable size - theta. + imagU := sinTable at: theta + 1] + ifFalse: + [realU := (sinTable at: theta - (n//4) + 1) negated. + imagU := sinTable at: (n//2) - theta + 1]. + forward ifFalse: [imagU := imagU negated]. +" + Here is the inner loop... + j to: n by: lev do: + [:i | hand-transformed to whileTrue... +" + i := j. + [i <= n] whileTrue: + [ip := i + lev1. + realT := ((realData at: ip) * realU) - ((imagData at: ip) * imagU). + imagT := ((realData at: ip) * imagU) + ((imagData at: ip) * realU). + realData at: ip put: (realData at: i) - realT. + imagData at: ip put: (imagData at: i) - imagT. + realData at: i put: (realData at: i) + realT. + imagData at: i put: (imagData at: i) + imagT. + i := i + lev]]]. + forward ifFalse: [self scaleData] "Reverse transform must scale to be an inverse"! ! +!MorphicUIManager methodsFor: 'ui requests' stamp: 'ar 7/22/2010 14:27' prior: 36614573! +edit: aText label: labelString accept: anAction + "Open an editor on the given string/text" + | window | + window := Workspace open. + labelString ifNotNil: [ window setLabel: labelString ]. + "By default, don't style in UIManager edit: requests" + window model + shouldStyle: false; + acceptContents: aText; + acceptAction: anAction. + ^window.! ! + +"ToolBuilder-Morphic"! +!ChangesOrganizer commentStamp: 'cbr 7/27/2010 19:17' prior: 59239452! +I manage ChangeSets in the system. See the protocols on my class side. + +For an example of what I can do, select the following line in a Workspace and print it. + + +ChangesOrganizer allChangeSetNames! +!Debugger commentStamp: '<historical>' prior: 59270384! +I represent the machine state at the time of an interrupted process. I also represent a query path into the state of the process. The debugger is typically viewed through a window that views the stack of suspended contexts, the code for, and execution point in, the currently selected message, and inspectors on both the receiver of the currently selected message, and the variables in the current context. + +Special note on recursive errors: +Some errors affect Squeak's ability to present a debugger. This is normally an unrecoverable situation. However, if such an error occurs in an isolation layer, Squeak will attempt to exit from the isolation layer and then present a debugger. Here is the chain of events in such a recovery. + + * A recursive error is detected. + * The current project is queried for an isolationHead + * Changes in the isolationHead are revoked + * The parent project of isolated project is returned to + * The debugger is opened there and execution resumes. + +If the user closes that debugger, execution continues in the outer project and layer. If, after repairing some damage, the user proceeds from the debugger, then the isolationHead is re-invoked, the failed project is re-entered, and execution resumes in that world. ! +!SavedMultiWindowState methodsFor: 'operations' stamp: 'eem 8/11/2010 13:27' prior: 37219763! +selectWindowsMenu + | menu currentItem | + menu := MenuMorph new defaultTarget: self. + models withIndexDo: + [:model :index| | modelLabel | + modelLabel := index = currentModelIndex + ifTrue: [model multiWindowName] + ifFalse: [model multiWindowNameForState: (modelStates at: index) first]. + models size > 1 ifTrue: + [modelLabel := index printString, '. ', modelLabel]. + menu + add: (index = currentModelIndex + ifTrue: [Text string: modelLabel attribute: TextEmphasis bold] + ifFalse: + [((modelStates at: index) last anySatisfy: [:editState| editState notNil]) + ifTrue: [Text string: modelLabel attribute: TextColor red] + ifFalse: [modelLabel]]) + target: self + selector: #selectWindowIndex: + argument: index. + index = currentModelIndex ifTrue: + [currentItem := menu lastItem]]. + menu + addLine; + add: 'new window' target: self selector: #addNewWindow; + add: 'copy this window' target: self selector: #copyWindow; + add: 'remove this window' target: self selector: #removeCurrentWindow. + models size <= 1 ifTrue: + [menu lastItem isEnabled: false]. + menu selectItem: currentItem event: nil. + ^menu! ! +!PackagePaneBrowser methodsFor: 'multi-window support' stamp: 'eem 8/11/2010 13:36' prior: 36921198! +multiWindowName + "Answer the string to display for the receiver in a multi-window." + ^String streamContents: + [:s| | str | + self package + ifNil: [s nextPut: $a; space; nextPutAll: self defaultBrowserTitle] + ifNotNil: + [:pkg| + self selectedClass + ifNil: [self selectedSystemCategoryName + ifNil: [s nextPutAll: pkg] + ifNotNil: [:cat| s nextPutAll: cat]] + ifNotNil: + [:class| + s nextPutAll: pkg; space; print: class. + self metaClassIndicated ifTrue: + [s nextPutAll: ' class']]]. + (str := self selectedMessageName) notNil + ifTrue: [s nextPutAll: '>>'; nextPutAll: str] + ifFalse: + [(str := self selectedMessageCategoryName) notNil + ifTrue: [s space; nextPut: ${; nextPutAll: str; nextPut: $}]]]! ! +!PackagePaneBrowser methodsFor: 'multi-window support' stamp: 'eem 8/11/2010 13:31'! +multiWindowNameForState: savedStateMessage + "Answer the string to display for the receiver in a multi-window." + | getarg | + getarg := [:keyword| savedStateMessage arguments at: (savedStateMessage selector keywords indexOf: keyword)]. + ^String streamContents: + [:s| + (getarg value: 'restoreToPackage:') + ifNil: [s nextPut: $a; space; nextPutAll: self defaultBrowserTitle] + ifNotNil: + [:pkg| + s nextPutAll: pkg. + (getarg value: 'className:') + ifNil: [(getarg value: 'category:') ifNotNil: + [:categoryName| s nextPut: $-; nextPutAll: categoryName]] + ifNotNil: + [:className| + s space; nextPutAll: className. + (getarg value: 'meta:') ifTrue: + [s nextPutAll: ' class']. + self isHierarchy ifTrue: + [s space; nextPutAll: ' Hierarchy']. + (getarg value: 'selector:') + ifNil: [(getarg value: 'protocol:') ifNotNil: + [:protocol| s space; nextPut: ${; nextPutAll: protocol; nextPut: $}]] + ifNotNil: [:selector| s nextPutAll: '>>'; nextPutAll: selector]]]]! ! +!MessageSet methodsFor: 'message list' stamp: 'nice 8/19/2010 16:33' prior: 54367564! +sortByDate + "Sort the message-list by date of time-stamp" + + | assocs inOrder | + assocs := messageList collect: + [:aRef | | aDate aCompiledMethod | + aDate := aRef methodSymbol == #Comment + ifTrue: + [aRef actualClass organization dateCommentLastSubmitted] + ifFalse: + [aCompiledMethod := aRef actualClass compiledMethodAt: aRef methodSymbol ifAbsent: [nil]. + aCompiledMethod ifNotNil: [aCompiledMethod dateMethodLastSubmitted]]. + aRef -> (aDate ifNil: [Date fromString: '01/01/1996'])]. "The dawn of Squeak history" + inOrder := assocs asArray sort: [:a :b | a value < b value]. + + messageList := inOrder collect: [:assoc | assoc key]. + self changed: #messageList! ! +!ChangeList methodsFor: 'menu actions' stamp: 'eem 7/22/2010 13:40' prior: 34370542! +selectUnchangedDefinitions + "Selects all recognizable definitions for which there is already a definition in the current image, whose source is exactly the same." + | change class tokens | + Cursor read showWhile: + [1 to: changeList size do: + [:i | change := changeList at: i. + listSelections at: i put: false. + + (change type = #method + and: [(class := change methodClass) notNil + and: [class includesSelector: change methodSelector]]) ifTrue: + [listSelections + at: i + put: change string withBlanksCondensed + = (class sourceCodeAt: change methodSelector) asString withBlanksCondensed]. + + (change type == #classComment + and: [(class := change commentClass) notNil]) ifTrue: + [listSelections at: i put: change string = class comment asString]. + + change type == #doIt ifTrue: + [tokens := Scanner new scanTokens: change string. + + ((tokens select: + [:substr| #(subclass: variableSubclass: variableByteSubclass: variableWordSubclass: + instanceVariableNames: classVariableNames: ) includes: substr]) + asSet size >= 3 + and: [(class := Smalltalk at: tokens third ifAbsent: []) notNil + and: [class isBehavior]]) ifTrue: + [listSelections + at: i + put: change string withBlanksCondensed + = class definition withBlanksCondensed]. + + (tokens size = 4 + and: [tokens second == #class + and: [tokens third == #instanceVariableNames: + and: [(class := Smalltalk at: tokens first ifAbsent: []) notNil + and: [class isBehavior]]]]) ifTrue: + [listSelections + at: i + put: change string withBlanksCondensed + = class class definition withBlanksCondensed]. + + (tokens size = 3 + and: [tokens second == #removeSelector: + and: [(class := Smalltalk at: tokens first ifAbsent: []) isNil + or: [class isBehavior and: [(class includesSelector: tokens third) not]]]]) ifTrue: + [listSelections at: i put: true]. + + (tokens size = 4 + and: [tokens second == #class + and: [tokens third == #removeSelector: + and: [(class := Smalltalk at: tokens first ifAbsent: []) isNil + or: [class isBehavior and: [(class class includesSelector: tokens fourth) not]]]]]) ifTrue: + [listSelections at: i put: true]]]]. + + self changed: #allSelections! ! +!Debugger class methodsFor: 'private' stamp: 'eem 7/26/2010 18:01'! +ifPreferredInterruptUIProcessIfBlocked: errorWasInUIProcess + | sema | + errorWasInUIProcess ifTrue: + [^self]. + self interruptUIProcessIfBlockedOnErrorInBackgroundProcess ifFalse: + [^self]. + "Only interrupt the UI if it is unresponsive (and so is doing something that needs + interrupting). Test using addDeferredUIMessage: to see if it is running UI activities." + sema := Semaphore new. + Project current addDeferredUIMessage: [sema signal]. + (sema waitTimeoutMSecs: 100) ifTrue: + [[Project current interruptName: 'Interrupt from Background Error'] fork] + + "| s | + s := Semaphore new. + [self assert: 0 > 1000. s signal] fork. + s wait"! ! +!Debugger class methodsFor: 'preferences' stamp: 'eem 7/26/2010 15:52'! +interruptUIProcessIfBlockedOnErrorInBackgroundProcess + <preference: 'Interrupt UI process on background error' + category: 'debug' + description: 'When enabled, the debugger will interrupt the UI process if an error occurs in a background process and the UI process is blocked.' + type: #Boolean> + ^InterruptUIProcessIfBlockedOnErrorInBackgroundProcess ifNil: [false]! ! +!Debugger class methodsFor: 'preferences' stamp: 'eem 7/26/2010 15:53'! +interruptUIProcessIfBlockedOnErrorInBackgroundProcess: aBoolean + InterruptUIProcessIfBlockedOnErrorInBackgroundProcess := aBoolean! ! +!Debugger class methodsFor: 'opening' stamp: 'eem 7/26/2010 15:51' prior: 19607647! +openOn: process context: context label: title contents: contentsStringOrNil fullView: bool + "Open a notifier in response to an error, halt, or notify. A notifier view just shows a short view of the sender stack and provides a menu that lets the user open a full debugger." + + | controller errorWasInUIProcess block | + Smalltalk isMorphic + ifTrue: [errorWasInUIProcess := Project spawnNewProcessIfThisIsUI: process] + ifFalse: [controller := ScheduledControllers activeControllerProcess == process + ifTrue: [ScheduledControllers activeController]]. + block := [ + [ | debugger | + + debugger := self new process: process controller: controller context: context. + Smalltalk isMorphic + ifTrue: ["schedule debugger in deferred UI message to address redraw + problems after opening a debugger e.g. from the testrunner." + "WorldState addDeferredUIMessage: ["bool + ifTrue: [debugger openFullNoSuspendLabel: title] + ifFalse: [debugger openNotifierContents: contentsStringOrNil label: title]] + ifFalse: ["deferred UI message would require special controller in MVC" + bool + ifTrue: [debugger openFullNoSuspendLabel: title] + ifFalse: [debugger openNotifierContents: contentsStringOrNil label: title]]. + debugger errorWasInUIProcess: errorWasInUIProcess. + Preferences logDebuggerStackToFile ifTrue: [ + Smalltalk logError: title inContext: context to: 'SqueakDebug.log']. + Smalltalk isMorphic + ifFalse: [ScheduledControllers searchForActiveController "needed since openNoTerminate (see debugger #open...) does not set up activeControllerProcess if activeProcess (this fork) is not the current activeControllerProcess (see #scheduled:from:)"]. + ] on: Error do: [:ex | + self primitiveError: + 'Orginal error: ', + title asString, '. + Debugger error: ', + ([ex description] on: Error do: ['a ', ex class printString]), ':' + ] + ]. + self ifPreferredInterruptUIProcessIfBlocked: errorWasInUIProcess. + Project current addDeferredUIMessage: block. + process suspend! ! +!Debugger methodsFor: 'accessing' stamp: 'abc 2/12/2010 15:02' prior: 53617029! +debuggerMap + ^self selectedContext debuggerMap! ! +!MethodContext methodsFor: '*Tools-Inspector' stamp: 'ar 8/19/2010 12:16'! +inspectorClass + "Answer the class of the inspector to be used on the receiver. Called by inspect; + use basicInspect to get a normal (less useful) type of inspector." + + ^ ContextInspector! ! +!ContextInspector methodsFor: 'accessing' stamp: 'ar 8/19/2010 12:24'! +fieldList + "Answer the base field list plus an abbreviated list of indices." + + ^ self baseFieldList , (object tempNames collect:[:t| '[',t,']'])! ! +!ContextInspector methodsFor: 'accessing' stamp: 'ar 8/19/2010 12:21'! +selection + "The receiver has a list of variables of its inspected object. + One of these is selected. Answer the value of the selected variable." + | basicIndex | + selectionIndex = 0 ifTrue: [^ '']. + selectionIndex = 1 ifTrue: [^ object]. + selectionIndex = 2 ifTrue: [^ object longPrintStringLimitedTo: 20000]. + (selectionIndex - 2) <= object class instSize + ifTrue: [^ object instVarAt: selectionIndex - 2]. + basicIndex := selectionIndex - 2 - object class instSize. + ^object debuggerMap namedTempAt: basicIndex in: object +! ! +!Browser methodsFor: 'multi-window support' stamp: 'eem 8/11/2010 13:23'! +multiWindowNameForState: savedStateMessage + "Answer the string to display for the receiver in a multi-window." + | getarg | + getarg := [:keyword| savedStateMessage arguments at: (savedStateMessage selector keywords indexOf: keyword)]. + ^String streamContents: + [:s| + (getarg value: 'className:') + ifNil: [(getarg value: 'restoreToCategory:') + ifNil: [s nextPut: $a; space; nextPutAll: self defaultBrowserTitle] + ifNotNil: [:categoryName| s nextPutAll: categoryName]] + ifNotNil: + [:className| + s nextPutAll: className. + (getarg value: 'meta:') ifTrue: + [s nextPutAll: ' class']. + self isHierarchy ifTrue: + [s space; nextPutAll: ' Hierarchy']. + (getarg value: 'selector:') + ifNil: [(getarg value: 'protocol:') ifNotNil: + [:protocol| s space; nextPut: ${; nextPutAll: protocol; nextPut: $}]] + ifNotNil: [:selector| s nextPutAll: '>>'; nextPutAll: selector]]]! ! +!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'nice 8/19/2010 14:08' prior: 54384128! +contents: aString notifying: aController + "Take what the user typed and find all selectors containing it" + + | tokens | + contents := aString. + classList := #(). classListIndex := 0. + selectorIndex := 0. + tokens := contents asString findTokens: ' .'. + selectorList := Cursor wait showWhile: [ + tokens size = 1 + ifTrue: [(Symbol selectorsContaining: contents asString) asArray + sort: [:x :y | x asLowercase <= y asLowercase]] + ifFalse: [self quickList]]. "find selectors from a single example of data" + self changed: #messageList. + self changed: #classList. + ^ true! ! + +"Tools"! +!HelpBrowser methodsFor: 'stepping' stamp: 'tbn 8/19/2010 09:47'! +step + "Do nothing when the window dispatches stepping back to the model"! ! + +"HelpSystem-Core"! +!Dictionary methodsFor: 'adding' stamp: 'ar 8/24/2010 20:19' prior: 19699828! +addAll: aCollection + "Include all the associations of aCollection as the receiver's elements. Answer + aCollection. Any collection containing associations can be used as argument." + + aCollection == self ifFalse: [ + aCollection associationsDo: [:assoc| self add: assoc]. + ]. + ^aCollection! ! +!WeakMessageSend methodsFor: 'evaluating' stamp: 'nice 8/22/2010 21:36' prior: 53141355! +valueWithEnoughArguments: anArray + "call the selector with enough arguments from arguments and anArray" + ^self + withEnsuredReceiverAndArgumentsDo: [ :r :a | + r + perform: selector + withArguments: a ] + withEnoughArguments: anArray + otherwise: [ ]! ! +!WeakMessageSend methodsFor: 'private' stamp: 'nice 8/22/2010 21:37'! +withEnsuredReceiverAndArgumentsDo: aBlock withEnoughArguments: anArray otherwise: altBlock + "call the selector with enough arguments from arguments and anArray" + | r selfArgs enoughArgs | + r := self receiver. + r ifNil: [ ^altBlock value ]. + + selfArgs := self arguments. + selfArgs with: shouldBeNil do: [ :arg :flag | + arg ifNil: [ flag ifFalse: [ ^altBlock value ]] + ]. + + enoughArgs := Array new: selector numArgs. + enoughArgs replaceFrom: 1 + to: ( selfArgs size min: enoughArgs size) + with: selfArgs + startingAt: 1. + enoughArgs size > selfArgs size ifTrue: [ + enoughArgs replaceFrom: selfArgs size + 1 + to: (selfArgs size + anArray size min: enoughArgs size) + with: anArray + startingAt: 1. + ]. + ^aBlock value: r value: enoughArgs! ! +!LargePositiveInteger methodsFor: 'printing' stamp: 'ul 8/23/2010 13:56' prior: 51540930! +printOn: aStream base: b nDigits: n + "Append a representation of this number in base b on aStream using n digits. + In order to reduce cost of LargePositiveInteger ops, split the number of digts approximatily in two + Should be invoked with: 0 <= self < (b raisedToInteger: n)" + + | halfPower half head tail | + n <= 1 ifTrue: [ + n <= 0 ifTrue: [self error: 'Number of digits n should be > 0']. + + "Note: this is to stop an infinite loop if one ever attempts to print with a huge base + This can happen because choice was to not hardcode any limit for base b + We let Character>>#digitValue: fail" + ^aStream nextPut: (Character digitValue: self) ]. + halfPower := n bitShift: -1. + half := b raisedToInteger: halfPower. + head := self quo: half. + tail := self - (head * half). + head printOn: aStream base: b nDigits: n - halfPower. + tail printOn: aStream base: b nDigits: halfPower! ! + +WeakMessageSend removeSelector: #isValid! + +WeakMessageSend removeSelector: #ensureReceiverAndArguments! + +WeakMessageSend removeSelector: #ensureReceiver! + +WeakMessageSend removeSelector: #ensureArguments! + +MessageSend removeSelector: #isValid! + +Time class removeSelector: #primUtcWithOffset! +!WeakActionSequenceTrappingErrors methodsFor: 'evaluating' stamp: 'nice 8/22/2010 17:47' prior: 53140572! +valueStartingFrom: startIndex + "Do the same as my parent, but make sure that all actions that do not + give errors are evaluated before resignaling the ones that gave errors + (giving the chance to clients to handle them)." + + "Note: I currently trap Halt,Error so that I am sure to get a Halt event in case of a Halt. This is being fixed in the exception system - when the fix is done it will be enough to capture only Error." + + | each answer | + answer := nil. + startIndex to: self size do: [:index | + each := self at: index. + [ + answer := each valueOtherwise: [ answer ]. + ] + on: Halt , Error + do: [:exc | + self valueStartingFrom: index + 1. + exc pass]]. + ^ answer! ! +!WeakActionSequenceTrappingErrors methodsFor: 'evaluating' stamp: 'nice 8/22/2010 17:48' prior: 53139705! +valueWithArguments: anArray startingFrom: startIndex + "Do the same as my parent, but make sure that all actions that do not + give errors are evaluated before resignaling the ones that gave errors + (giving the chance to clients to handle them)." + + "Note: I currently trap Halt,Error so that I am sure to get a Halt event in case of a Halt. This is being fixed in the exception system - when the fix is done it will be enough to capture only Error." + + | each answer | + answer := nil. + startIndex to: self size do: [:index | + each := self at: index. + [ + answer := each valueWithArguments: anArray otherwise: [ answer ]. + ] + on: Halt , Error + do: [:exc | + self valueWithArguments: anArray startingFrom: index + 1. + exc pass]]. + ^ answer! ! +!StringMorph methodsFor: 'menu' stamp: 'ul 8/23/2010 00:49' prior: 52714040! +changeFont + + | chooser originalFont | + originalFont := self fontToUse. + self openModal: ( + Cursor wait showWhile: [ + | window | + window := UIManager default + chooseFont: 'Choose a Font' + for: self + setSelector: #font: + getSelector: originalFont. + "We have to save the model here, because it will be gone when the window is closed." + chooser := window model. + window ]). + originalFont = self fontToUse ifFalse: [ + "Ensure that we restore the original font in case it was changed, but Cancel was clicked." + self font: (chooser result ifNil: [ originalFont ]) ]! ! + +"Morphic"! +!SocketStream methodsFor: 'stream in' stamp: 'ar 8/22/2010 13:27' prior: 38714517! +upTo: aCharacterOrByte limit: nBytes + "Return data up to, but not including given character or byte. If the character is not in the stream, or not found within nBytes answer the available contents of the stream" + + | target index result searchedSoFar | + "Deal with ascii vs. binary" + self isBinary + ifTrue:[target := aCharacterOrByte asInteger] + ifFalse:[target := aCharacterOrByte asCharacter]. + + "Look in the current inBuffer first" + index := inBuffer indexOf: target startingAt: lastRead + 1 ifAbsent:[0]. + + (index > 0 and: [(index + 1) <= inNextToWrite]) ifTrue: ["found it" + result := self nextInBuffer: index - lastRead - 1. + self skip: 1. + ^ result + ]. + + [searchedSoFar := self inBufferSize. + "Receive more data" + self receiveData. + "We only get recentlyRead = 0 in the case of a non-signaling socket close." + recentlyRead > 0] whileTrue:[ + "Data begins at lastRead + 1, we add searchedSoFar as offset." + + index := inBuffer indexOf: target + startingAt: (lastRead + searchedSoFar + 1) + ifAbsent:[0]. + (index > 0 and: [(index + 1) <= inNextToWrite]) ifTrue: ["found it" + result := self nextInBuffer: index - lastRead - 1. + self skip: 1. + ^ result + ]. + + "Check if we've exceeded the max. amount" + (nBytes notNil and:[inNextToWrite - lastRead > nBytes]) + ifTrue:[^self nextAllInBuffer]. + ]. + + "not found and (non-signaling) connection was closed" + ^self nextAllInBuffer! ! +!SocketStream methodsFor: 'stream in' stamp: 'ar 8/22/2010 13:32' prior: 38716412! +upToAll: aStringOrByteArray limit: nBytes + "Answer a subcollection from the current access position to the occurrence (if any, but not inclusive) of aStringOrByteArray. If aCollection is not in the stream, or not found within nBytes answer the available contents of the stream" + + | index sz result searchedSoFar target | + "Deal with ascii vs. binary" + self isBinary + ifTrue:[target := aStringOrByteArray asByteArray] + ifFalse:[target := aStringOrByteArray asString]. + + sz := target size. + "Look in the current inBuffer first" + index := inBuffer indexOfSubCollection: target + startingAt: lastRead - sz + 2. + (index > 0 and: [(index + sz) <= inNextToWrite]) ifTrue: ["found it" + result := self nextInBuffer: index - lastRead - 1. + self skip: sz. + ^ result + ]. + + [searchedSoFar := self inBufferSize. + "Receive more data" + self receiveData. + recentlyRead > 0] whileTrue:[ + + "Data begins at lastRead + 1, we add searchedSoFar as offset and + backs up sz - 1 so that we can catch any borderline hits." + + index := inBuffer indexOfSubCollection: target + startingAt: (lastRead + searchedSoFar - sz + 2 max: 1). + (index > 0 and: [(index + sz) <= inNextToWrite]) ifTrue: ["found it" + result := self nextInBuffer: index - lastRead - 1. + self skip: sz. + ^ result + ]. + "Check if we've exceeded the max. amount" + (nBytes notNil and:[inNextToWrite - lastRead > nBytes]) + ifTrue:[^self nextAllInBuffer]. + ]. + + "not found and (non-signaling) connection was closed" + ^self nextAllInBuffer! ! + +UrlArgumentList removeSelector: #associationsDo:! + +"Network"! + +| user pw | +Utilities setAuthorInitials. +user := UIManager default request: 'Repository user name'. +pw := UIManager default requestPassword: 'Monticello password'. +MCHttpRepository allSubInstancesDo: [ : rep | + rep user: user; + password: pw ]! + +MCFileBasedRepository flushAllCaches! + +----QUIT----{24 August 2010 . 9:00:45 pm} VMMaker-Squeak4.1.image priorSource: 5025556! + +----STARTUP----{28 August 2010 . 3:54:26 pm} as /Users/eliot/Cog/oscog/Cog.squeakvm.org/image/VMMaker-Squeak4.1.image! + + +EncounteredUnknownBytecode! + +----QUIT/NOSAVE----{28 August 2010 . 3:59:45 pm} VMMaker-Squeak4.1.image priorSource: 5189951! + +----STARTUP----{28 August 2010 . 4:07:08 pm} as /Users/eliot/Cog/oscog/Cog.squeakvm.org/image/VMMaker-Squeak4.1.image! + + +----QUIT/NOSAVE----{28 August 2010 . 4:07:49 pm} VMMaker-Squeak4.1.image priorSource: 5189951! \ No newline at end of file

Modified: branches/Cog/image/VMMaker-Squeak4.1.image =================================================================== (Binary files differ)

Modified: branches/Cog/macbuild/CoreVM.plist =================================================================== --- branches/Cog/macbuild/CoreVM.plist 2010-09-03 00:40:30 UTC (rev 2274) +++ branches/Cog/macbuild/CoreVM.plist 2010-09-04 15:52:10 UTC (rev 2275) @@ -438,7 +438,7 @@ <key>SqueakDebug</key> <integer>0</integer> <key>SqueakEncodingType</key> - <string>macintosh</string> + <string>UTF-8</string> <key>SqueakExplicitWindowOpenNeeded</key> <false/> <key>SqueakFloatingWindowGetsFocus</key>