!TPureBehavior methodsFor: 'adding/removing methods' stamp: 'adrian_lienhard 2/17/2009 22:00'! methodDictAddSelectorSilently: selector withMethod: compiledMethod self basicAddSelector: selector withMethod: compiledMethod! ! !CompiledMethod methodsFor: 'private' stamp: 'adrian_lienhard 2/1/2009 17:31'! getSourceReplacingSelectorWith: newSelector | oldKeywords newKeywords args newSelectorWithArgs source oldSelector s | source := self getSource. oldSelector := self parserClass new parseSelector: source. oldSelector = newSelector ifTrue: [ ^ source ]. oldKeywords := oldSelector keywords. newKeywords := (newSelector ifNil: [self defaultSelector]) keywords. self assert: oldKeywords size = newKeywords size. args := (self methodClass parserClass new parseArgsAndTemps: source string notifying: nil) copyFrom: 1 to: self numArgs. newSelectorWithArgs := String streamContents: [:stream | newKeywords withIndexDo: [:keyword :index | stream nextPutAll: keyword. stream space. args size >= index ifTrue: [ stream nextPutAll: (args at: index); space]]]. s := ReadStream on: source string. oldKeywords do: [ :each | s match: each ]. args isEmpty ifFalse: [ s match: args last ]. ^newSelectorWithArgs withBlanksTrimmed asText , s upToEnd! ! Behavior removeSelector: #addTraitSelector:withMethod:! Object subclass: #Behavior uses: TPureBehavior instanceVariableNames: 'superclass methodDict format' classVariableNames: 'ObsoleteSubclasses' poolDictionaries: '' category: 'Kernel-Classes'! !TClassAndTraitDescription methodsFor: 'fileIn/Out' stamp: 'al 10/13/2006 13:32'! fileOutCategory: aSymbol on: aFileStream moveSource: moveSource toFile: fileIndex "File a description of the receiver's category, aString, onto aFileStream. If moveSource, is true, then set the method source pointer to the new file position. Note when this method is called with moveSource=true, it is condensing the .sources file, and should only write one preamble per method category." | selectors | aFileStream cr. selectors := (aSymbol asString = ClassOrganizer allCategory) ifTrue: [ self organization allMethodSelectors ] ifFalse: [ self organization listAtCategoryNamed: aSymbol ]. "Overridden to preserve author stamps in sources file regardless" selectors do: [:sel | self printMethodChunk: sel withPreamble: true on: aFileStream moveSource: moveSource toFile: fileIndex]. ^ self! ! !TClassAndTraitDescription methodsFor: 'fileIn/Out' stamp: 'al 10/13/2006 13:40'! moveChangesTo: newFile "Used in the process of condensing changes, this message requests that the source code of all methods of the receiver that have been changed should be moved to newFile." | changes | changes := self methodDict keys select: [:sel | (self compiledMethodAt: sel) fileIndex > 1 ]. self fileOutChangedMessages: changes on: newFile moveSource: true toFile: 2! ! !TPureBehavior methodsFor: 'adding/removing methods' stamp: 'adrian_lienhard 2/1/2009 17:32'! basicAddSelector: selector withMethod: compiledMethod "Add the message selector with the corresponding compiled method to the receiver's method dictionary. Do this without sending system change notifications" | oldMethodOrNil | oldMethodOrNil := self lookupSelector: selector. self methodDict at: selector put: compiledMethod. compiledMethod methodClass: self. compiledMethod selector: selector. "Now flush Squeak's method cache, either by selector or by method" oldMethodOrNil ifNotNil: [oldMethodOrNil flushCache]. selector flushCache.! ! !TPureBehavior methodsFor: 'traits' stamp: 'adrian_lienhard 2/1/2009 17:43'! addTraitSelector: aSymbol withMethod: aCompiledMethod "Add aMethod with selector aSymbol to my methodDict. aMethod must not be defined locally." | source methodAndNode | self assert: [(self includesLocalSelector: aSymbol) not]. self ensureLocalSelectors. source := aCompiledMethod getSourceReplacingSelectorWith: aSymbol. methodAndNode := self compile: source classified: nil notifying: nil trailer: #(0 0 0 0) ifFail: [^nil]. methodAndNode method putSource: source fromParseNode: methodAndNode node inFile: 2 withPreamble: [:f | f cr; nextPut: $!!; nextChunkPut: 'Trait method'; cr]. self basicAddSelector: aSymbol withMethod: methodAndNode method! ! !TPureBehavior methodsFor: 'traits' stamp: 'al 10/13/2006 13:35'! updateMethodDictionarySelector: aSymbol "A method with selector aSymbol in myself or my traitComposition has been changed. Do the appropriate update to my methodDict (remove or update method) and return all affected selectors of me so that my useres get notified." | effectiveMethod modifiedSelectors descriptions selector | modifiedSelectors := IdentitySet new. descriptions := self hasTraitComposition ifTrue: [ self traitComposition methodDescriptionsForSelector: aSymbol ] ifFalse: [ #() ]. descriptions do: [:methodDescription | selector := methodDescription selector. (self includesLocalSelector: selector) ifFalse: [ methodDescription isEmpty ifTrue: [ self removeTraitSelector: selector. modifiedSelectors add: selector] ifFalse: [ effectiveMethod := methodDescription effectiveMethod. self addTraitSelector: selector withMethod: effectiveMethod. modifiedSelectors add: selector]]]. ^modifiedSelectors! ! !CompiledMethod methodsFor: 'source code management' stamp: 'adrian_lienhard 2/1/2009 17:40'! getSourceFor: selector in: class "Retrieve or reconstruct the source code for this method." | source flagByte | flagByte := self last. (flagByte = 0 or: [flagByte = 251 "some source-less methods have flag = 251, rest = 0" and: [((1 to: 3) collect: [:i | self at: self size - i]) = #(0 0 0)]]) ifTrue: ["No source pointer -- decompile without temp names" ^ self decompileString]. flagByte < 252 ifTrue: ["Magic sources -- decompile with temp names" ^ ((self decompilerClass new withTempNames: self tempNames) decompile: selector in: class method: self) decompileString]. "Situation normal; read the sourceCode from the file" [ source := self getSourceFromFile ] on: Error do: [ :ex | "An error can happen here if, for example, the changes file has been truncated by an aborted download. The present solution is to ignore the error and fall back on the decompiler. A more thorough solution should probably trigger a systematic invalidation of all source pointers past the end of the changes file. Consider that, as time goes on, the changes file will eventually grow large enough to cover the lost code, and then instead of falling into this error case, random source code will get returned." source := nil ]. source ifNotNil: [ ^ source ]. "Something really wrong -- decompile blind (no temps)" ^ self decompileString! ! !TraitMethodDescription methodsFor: 'accessing' stamp: 'adrian_lienhard 1/31/2009 21:42'! conflictMethod | method argumentNames binary numberOfArguments | self isConflict ifFalse: [^nil]. argumentNames := self getArgumentNames. binary := self isBinarySelector. numberOfArguments := binary ifTrue: [1] ifFalse: [argumentNames size + 2]. method := self generateMethod: self selector withMarker: CompiledMethod conflictMarker forArgs: argumentNames size binary: binary. ^method copyWithTempNames: argumentNames! ! !TraitMethodDescription methodsFor: 'accessing' stamp: 'adrian_lienhard 1/31/2009 21:33'! requiredMethod | templateMethod argumentNames numberOfArguments binary | self isRequired ifFalse: [^nil]. self size = 1 ifTrue: [^self locatedMethods anyOne method]. argumentNames := self getArgumentNames. binary := self isBinarySelector. numberOfArguments := binary ifTrue: [1] ifFalse: [argumentNames size + 2]. templateMethod := self generateMethod: self selector withMarker: CompiledMethod implicitRequirementMarker forArgs: argumentNames size binary: binary. ^templateMethod copyWithTempNames: argumentNames! ! !TraitMethodDescription methodsFor: 'private' stamp: 'adrian_lienhard 1/31/2009 21:43'! generateMethod: aSelector withMarker: aSymbol forArgs: aNumber binary: aBoolean | source node | source := String streamContents: [:stream | aNumber < 1 ifTrue: [stream nextPutAll: 'selector'] ifFalse: [aBoolean ifTrue: [ stream nextPutAll: '* anObject'] ifFalse: [ 1 to: aNumber do: [:argumentNumber | stream nextPutAll: 'with:'; space; nextPutAll: 'arg'; nextPutAll: argumentNumber asString; space]]]. stream cr; tab; nextPutAll: 'self '; nextPutAll: aSymbol]. node := self class compilerClass new compile: source in: self class notifying: nil ifFail: []. ^(node generate) selector: aSelector; yourself! ! !PureBehaviorTest methodsFor: 'testing-applying trait composition' stamp: 'al 10/13/2006 13:52'! testChangeSuperclass "self run: #testChangeSuperclass" "Test that when the superclass of a class is changed the non-local methods of the class sending super are recompiled to correctly store the new superclass." | aC2 newSuperclass | aC2 := self c2 new. "C1 is current superclass of C2" self assert: aC2 m51. self assert: self c2 superclass == self c1. self deny: (self c2 localSelectors includes: #m51). "change superclass of C2 from C1 to X" newSuperclass := self createClassNamed: #X superclass: Object uses: {}. newSuperclass subclass: self c2 name uses: self c2 traitComposition instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self c2 category. self assert: self c2 superclass == newSuperclass. newSuperclass compile: 'foo ^17'. self assert: aC2 m51 = 17. self deny: (self c2 localSelectors includes: #m51). self c2 compile: 'm51 ^19'. self assert: aC2 m51 = 19.! ! !PureBehaviorTest methodsFor: 'testing-applying trait composition' stamp: 'adrian_lienhard 2/1/2009 16:43'! testMethodClass "Test sharing of compiled methods between traits and their users. Methods are installed in exactly one behavior, however, the source pointers of methods are shared (unless sources or changes have been condensed). Verify that methodClass properties are set correctly." "self debug: #testMethodClass" | m1 m2 | m1 := self t5 >> #m51. m2 := self c2 >> #m51. self assert: m1 methodClass == self t5. self assert: m2 methodClass == self c2. self deny: m1 == m2. self deny: m1 sourcePointer = m2 sourcePointer.! ! !PureBehaviorTest methodsFor: 'testing-applying trait composition' stamp: 'adrian_lienhard 1/31/2009 20:51'! testSuperSends "self debug: #testSuperSends" | aC2 | aC2 := self c2 new. self assert: aC2 m51. self deny: aC2 foo. self deny: aC2 bar! ! !SystemTest methodsFor: 'testing' stamp: 'adrian_lienhard 1/31/2009 18:48'! testClassFromPattern "self debug: #testClassFromPattern" self assert: (SystemNavigation default classFromPattern: 'TComposingD' withCaption: '') = TComposingDescription! ! !TraitTest methodsFor: 'testing' stamp: 'al 10/13/2006 13:54'! testExplicitRequirement "self run: #testExplicitRequirement" self t1 compile: 'm self explicitRequirement'. self t2 compile: 'm ^true'. self deny: self t4 >> #m == (self t2 >> #m). self assert: self c2 new m. self t2 removeSelector: #m. self deny: self t5 >> #m == (self t1 >> #m). self should: [self c2 new m] raise: Error! ! !TraitTest methodsFor: 'testing' stamp: 'al 10/13/2006 13:54'! testRequirement "self debug: #testRequirement" self t1 compile: 'm self requirement'. self t2 compile: 'm ^true'. self assert: self c2 new m. self t2 removeSelector: #m. self should: [self c2 new m] raise: Error! ! TraitsTestCase removeSelector: #testChangeSuperclass! TraitMethodDescription class removeSelector: #initialize! TraitMethodDescription removeSelector: #conflictMethodForArguments:ifAbsentPut:! TraitMethodDescription removeSelector: #requiredMethodForArguments:ifAbsentPut:! TraitBehavior removeSelector: #basicAddSelector:withMethod:! ClassDescription removeSelector: #fileOutCategory:on:moveSource:toFile:! Object subclass: #TraitMethodDescription instanceVariableNames: 'selector locatedMethods' classVariableNames: '' poolDictionaries: '' category: 'Traits-Composition'! Smalltalk allTraits do: [ :each | each notifyUsersOfChangedSelectors: each selectors ]! "Postscript: Leave the line above, and replace the rest of this comment by a useful one. Executable statements should follow this comment, and should be separated by periods, with no exclamation points (!!). Be sure to put any further comments in double-quotes, like this one." |repository| repository := MCHttpRepository location: 'http://www.squeaksource.com/Pharo/' user: '' password: ''. (repository loadVersionFromFileNamed:'ScriptLoader-adrian_lienhard.766.mcz') load. [ ScriptLoader new update10241 ] on: Warning do: [:ex | ex resume]. !