SystemOrganization addCategory: #'LanguageAspects-Core'! SystemOrganization addCategory: #'LanguageAspects-Tests'! SystemOrganization addCategory: #'LanguageAspects-Examples'! CUCompositeParser subclass: #LASmalltalkParser instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'LanguageAspects-Core'! LASmalltalkParser subclass: #LASmalltalkCompiler instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'LanguageAspects-Core'! !LASmalltalkCompiler methodsFor: 'grammar' stamp: 'lr 9/26/2008 11:33'! assignment super assignment ==> #first! ! !LASmalltalkCompiler methodsFor: 'grammar-messages' stamp: 'lr 9/23/2008 19:16'! binaryExpression super binaryExpression map: [ :receiver :message | self build: receiver message: message ]! ! !LASmalltalkCompiler methodsFor: 'grammar-messages' stamp: 'lr 9/23/2008 19:26'! binaryMessage super binaryMessage ==> [ :nodes | Array with: nodes first value with: (Array with: nodes second) ]! ! !LASmalltalkCompiler methodsFor: 'private' stamp: 'lr 9/23/2008 20:53'! build: aNode message: anArray ^ anArray isEmptyOrNil ifTrue: [ aNode ] ifFalse: [ anArray inject: aNode into: [ :receiver :pair | pair isEmptyOrNil ifTrue: [ receiver ] ifFalse: [ RBMessageNode receiver: receiver selector: pair first asSymbol arguments: pair last ] ] ]! ! !LASmalltalkCompiler methodsFor: 'grammar-messages' stamp: 'lr 9/23/2008 19:49'! cascadeExpression ^ super cascadeExpression map: [ :receiver :messages | messages isEmpty ifTrue: [ receiver ] ifFalse: [ | sends | sends := OrderedCollection new: messages size + 1. sends addLast: receiver. messages do: [ :each | sends addLast: (RBMessageNode receiver: receiver receiver selector: each first asSymbol arguments: each last) ]. RBCascadeNode messages: sends ] ]! ! !LASmalltalkCompiler methodsFor: 'grammar-messages' stamp: 'lr 9/23/2008 19:39'! cascadeMessage super cascadeMessage ==> [ :nodes | nodes second ]! ! !LASmalltalkCompiler methodsFor: 'grammar' stamp: 'lr 9/23/2008 20:34'! expression super expression map: [ :variables :message | variables isEmpty ifTrue: [ message ] ifFalse: [ variables reverse inject: message into: [ :result :each | RBAssignmentNode variable: each value: result ] ] ]! ! !LASmalltalkCompiler methodsFor: 'grammar-messages' stamp: 'lr 9/23/2008 20:43'! keywordExpression super keywordExpression map: [ :receiver :message | self build: receiver message: (Array with: message) ]! ! !LASmalltalkCompiler methodsFor: 'grammar-messages' stamp: 'lr 9/23/2008 20:41'! keywordMessage super keywordMessage ==> [ :nodes | Array with: (nodes inject: String new into: [ :result :each | result , each first value ]) with: (nodes collect: [ :each | each second ]) ]! ! !LASmalltalkCompiler methodsFor: 'grammar' stamp: 'lr 9/23/2008 19:59'! method super method map: [ :declaration :sequence | RBMethodNode selector: declaration first asSymbol arguments: declaration second body: sequence ]! ! !LASmalltalkCompiler methodsFor: 'grammar' stamp: 'lr 9/23/2008 20:35'! parens super parens ==> #second! ! !LASmalltalkCompiler methodsFor: 'grammar' stamp: 'lr 9/23/2008 20:00'! return super return map: [ :token :expression | RBReturnNode value: expression ]! ! !LASmalltalkCompiler methodsFor: 'grammar' stamp: 'lr 9/23/2008 20:01'! sequence super sequence map: [ :temporaries :statements | RBSequenceNode temporaries: temporaries statements: statements ]! ! !LASmalltalkCompiler methodsFor: 'grammar-messages' stamp: 'lr 9/23/2008 19:15'! unaryExpression super unaryExpression map: [ :receiver :message | self build: receiver message: message ]! ! !LASmalltalkCompiler methodsFor: 'grammar-messages' stamp: 'lr 9/23/2008 19:25'! unaryMessage super unaryMessage ==> [ :node | Array with: node value with: Array new ]! ! !LASmalltalkCompiler methodsFor: 'grammar' stamp: 'lr 9/23/2008 20:02'! variable super variable ==> [ :token | RBVariableNode identifierToken: token ]! ! !LASmalltalkParser methodsFor: 'grammar-literals' stamp: 'lr 9/23/2008 21:22'! arrayLiteral '#(' , (unaryToken / binaryToken / keywordToken / multiwordToken / literal) star , $) ==> [ :nodes | RBLiteralNode value: (nodes third collect: [ :each | each value ]) ]! ! !LASmalltalkParser methodsFor: 'grammar' stamp: 'lr 9/23/2008 20:27'! assignment variable , assignmentToken! ! !LASmalltalkParser methodsFor: 'token' stamp: 'lr 9/23/2008 19:54'! assignmentToken (':=' / '_') token! ! !LASmalltalkParser methodsFor: 'token-primitives' stamp: 'lr 9/23/2008 19:53'! binary ($~ / $- / $!! / $@ / $% / $& / $* / $+ / $= / $\ / $| / $? / $/ / $> / $<) , ($~ / $!! / $@ / $% / $& / $* / $+ / $= / $\ / $| / $? / $/ / $> / $<) star! ! !LASmalltalkParser methodsFor: 'grammar-messages' stamp: 'lr 9/23/2008 18:43'! binaryExpression unaryExpression , binaryMessage star! ! !LASmalltalkParser methodsFor: 'grammar-messages' stamp: 'lr 9/23/2008 18:42'! binaryMessage binaryToken , unaryExpression! ! !LASmalltalkParser methodsFor: 'grammar-methods' stamp: 'lr 9/23/2008 19:55'! binaryMethod binaryToken , variable ==> [ :nodes | Array with: nodes first value with: (Array with: nodes second) ]! ! !LASmalltalkParser methodsFor: 'token' stamp: 'lr 9/23/2008 19:53'! binaryToken binary token! ! !LASmalltalkParser methodsFor: 'grammar-blocks' stamp: 'lr 9/23/2008 16:51'! block ^ $[ flatten , blockArguments , sequence , $] flatten ==> [ :nodes | RBBlockNode arguments: nodes second body: nodes third ]! ! !LASmalltalkParser methodsFor: 'grammar-blocks' stamp: 'lr 9/23/2008 14:17'! blockArgument ^ $: , variable ==> [ :nodes | nodes second ]! ! !LASmalltalkParser methodsFor: 'grammar-blocks' stamp: 'lr 9/23/2008 16:51'! blockArguments ^ (blockArgument plus , $| flatten ==> [ :nodes | nodes first ]) / ($| flatten optional ==> [ :nodes | Array new ])! ! !LASmalltalkParser methodsFor: 'grammar-messages' stamp: 'lr 9/23/2008 19:29'! cascadeExpression keywordExpression , cascadeMessage star! ! !LASmalltalkParser methodsFor: 'grammar-messages' stamp: 'lr 9/23/2008 18:45'! cascadeMessage $; flatten , (keywordMessage / binaryMessage / unaryMessage)! ! !LASmalltalkParser methodsFor: 'token-primitives' stamp: 'lr 9/23/2008 19:53'! char $$ , #any! ! !LASmalltalkParser methodsFor: 'grammar-literals' stamp: 'lr 9/23/2008 13:33'! charLiteral ^ charToken ==> [ :token | RBLiteralNode literalToken: token value: token value second ]! ! !LASmalltalkParser methodsFor: 'token-literals' stamp: 'lr 9/23/2008 19:54'! charToken char token! ! !LASmalltalkParser methodsFor: 'creational' stamp: 'lr 9/23/2008 16:56'! createMessageSend: aCollection ^ RBMessageNode receiver: aCollection first selector: aCollection second first asSymbol arguments: aCollection second second asArray! ! !LASmalltalkParser methodsFor: 'grammar' stamp: 'lr 9/23/2008 20:27'! expression assignment star , cascadeExpression! ! !LASmalltalkParser methodsFor: 'grammar-literals' stamp: 'lr 9/23/2008 13:33'! falseLiteral ^ falseToken ==> [ :token | RBLiteralNode literalToken: token value: false ]! ! !LASmalltalkParser methodsFor: 'token-literals' stamp: 'lr 9/23/2008 19:54'! falseToken 'false' token! ! !LASmalltalkParser methodsFor: 'token-primitives' stamp: 'lr 9/23/2008 19:53'! identifier #letter , #word star! ! !LASmalltalkParser methodsFor: 'token' stamp: 'lr 9/23/2008 19:53'! identifierToken identifier token! ! !LASmalltalkParser methodsFor: 'token-primitives' stamp: 'lr 9/23/2008 19:53'! keyword identifier , $:! ! !LASmalltalkParser methodsFor: 'grammar-messages' stamp: 'lr 9/23/2008 18:44'! keywordExpression binaryExpression , keywordMessage optional! ! !LASmalltalkParser methodsFor: 'grammar-messages' stamp: 'lr 9/23/2008 18:44'! keywordMessage (keywordToken , binaryExpression) plus! ! !LASmalltalkParser methodsFor: 'grammar-methods' stamp: 'lr 9/23/2008 19:55'! keywordMethod (keywordToken , variable) plus ==> [ :nodes | Array with: (nodes inject: String new into: [ :result :each | result , each first value ]) with: (nodes collect: [ :each | each second ]) ]! ! !LASmalltalkParser methodsFor: 'token' stamp: 'lr 9/23/2008 19:53'! keywordToken keyword token! ! !LASmalltalkParser methodsFor: 'grammar' stamp: 'lr 9/23/2008 21:16'! literal trueLiteral / falseLiteral / nilLiteral / numberLiteral / charLiteral / stringLiteral / symbolLiteral / arrayLiteral! ! !LASmalltalkParser methodsFor: 'grammar' stamp: 'lr 9/23/2008 20:00'! method (keywordMethod / unaryMethod / binaryMethod) , sequence! ! !LASmalltalkParser methodsFor: 'token-primitives' stamp: 'lr 9/23/2008 21:06'! multiword keyword plus! ! !LASmalltalkParser methodsFor: 'token' stamp: 'lr 9/23/2008 21:12'! multiwordToken multiword token! ! !LASmalltalkParser methodsFor: 'grammar-literals' stamp: 'lr 9/23/2008 13:33'! nilLiteral ^ nilToken ==> [ :token | RBLiteralNode literalToken: token value: nil ]! ! !LASmalltalkParser methodsFor: 'token-literals' stamp: 'lr 9/23/2008 19:54'! nilToken 'nil' token! ! !LASmalltalkParser methodsFor: 'token-primitives' stamp: 'lr 9/23/2008 19:53'! number ($- optional , #digit plus) , ($. , #digit plus) optional! ! !LASmalltalkParser methodsFor: 'grammar-literals' stamp: 'lr 9/23/2008 14:53'! numberLiteral ^ numberToken ==> [ :token | RBLiteralNode literalToken: token value: (Number readFrom: token value) ]! ! !LASmalltalkParser methodsFor: 'token-literals' stamp: 'lr 9/23/2008 19:54'! numberToken number token! ! !LASmalltalkParser methodsFor: 'grammar' stamp: 'lr 9/23/2008 20:00'! parens $( , expression , $)! ! !LASmalltalkParser methodsFor: 'grammar' stamp: 'lr 9/23/2008 20:00'! primary variable / literal / block / parens! ! !LASmalltalkParser methodsFor: 'grammar' stamp: 'lr 9/23/2008 20:00'! return $^ flatten , expression! ! !LASmalltalkParser methodsFor: 'grammar' stamp: 'lr 9/23/2008 20:00'! sequence temporaries , statements! ! !LASmalltalkParser methodsFor: 'accessing' stamp: 'lr 9/23/2008 21:30'! start ^ method end! ! !LASmalltalkParser methodsFor: 'grammar' stamp: 'lr 9/23/2008 20:04'! statements (return , $. flatten optional ==> [ :nodes | Array with: nodes first ]) / (expression , $. flatten , statements ==> [ :nodes | nodes third copyWithFirst: nodes first ]) / (expression , $. flatten optional ==> [ :nodes | Array with: nodes first ]) / ($. flatten optional ==> [ :node | #() ])! ! !LASmalltalkParser methodsFor: 'token-primitives' stamp: 'lr 9/23/2008 19:53'! string $' , (($' , $') / $' negate) star , $'! ! !LASmalltalkParser methodsFor: 'grammar-literals' stamp: 'lr 9/23/2008 20:46'! stringLiteral ^ stringToken ==> [ :token | RBLiteralNode literalToken: token value: ((token value copyFrom: 2 to: token size - 1) copyReplaceAll: '''''' with: '''') ]! ! !LASmalltalkParser methodsFor: 'token-literals' stamp: 'lr 9/23/2008 19:54'! stringToken string token! ! !LASmalltalkParser methodsFor: 'grammar-literals' stamp: 'lr 9/23/2008 21:11'! symbolLiteral ^ symbolToken ==> [ :nodes | RBLiteralNode literalToken: nodes value: nodes value asSymbol ]! ! !LASmalltalkParser methodsFor: 'token-literals' stamp: 'lr 9/23/2008 21:10'! symbolToken $# , (unaryToken / binaryToken / multiwordToken / stringToken) ==> #second! ! !LASmalltalkParser methodsFor: 'grammar' stamp: 'lr 9/23/2008 20:04'! temporaries ($| token , variable star , $| token ==> [ :nodes | nodes second ]) / (PPEpsilonParser new ==> [ :nodes | Array new ])! ! !LASmalltalkParser methodsFor: 'grammar-literals' stamp: 'lr 9/23/2008 13:33'! trueLiteral ^ trueToken ==> [ :token | RBLiteralNode literalToken: token value: true ]! ! !LASmalltalkParser methodsFor: 'token-literals' stamp: 'lr 9/23/2008 19:54'! trueToken 'true' token! ! !LASmalltalkParser methodsFor: 'token-primitives' stamp: 'lr 9/23/2008 21:07'! unary identifier , $: not! ! !LASmalltalkParser methodsFor: 'grammar-messages' stamp: 'lr 9/23/2008 19:07'! unaryExpression primary , unaryMessage star! ! !LASmalltalkParser methodsFor: 'grammar-messages' stamp: 'lr 9/23/2008 18:47'! unaryMessage unaryToken! ! !LASmalltalkParser methodsFor: 'grammar-methods' stamp: 'lr 9/23/2008 19:55'! unaryMethod identifierToken ==> [ :node | Array with: node value with: #() ]! ! !LASmalltalkParser methodsFor: 'token' stamp: 'lr 9/23/2008 21:07'! unaryToken unary token! ! !LASmalltalkParser methodsFor: 'grammar' stamp: 'lr 9/23/2008 20:02'! variable identifierToken! ! Object subclass: #LAAspect instanceVariableNames: 'active environments concerns pointcut' classVariableNames: '' poolDictionaries: '' category: 'LanguageAspects-Core'! LAAspect class instanceVariableNames: 'Default'! LAAspect class instanceVariableNames: 'Default'! !LAAspect class methodsFor: 'accessing' stamp: 'lr 10/10/2008 15:03'! default ^ Default ifNil: [ Default := self new ]! ! !LAAspect class methodsFor: 'initialization' stamp: 'lr 10/10/2008 15:08'! reset Default := nil. self subclasses do: [ :each | each reset ]! ! !LAAspect class methodsFor: 'initialization' stamp: 'lr 10/10/2008 15:03'! unload self default active: false! ! !LAAspect methodsFor: 'accessing' stamp: 'lr 10/10/2008 15:09'! active: aBoolean "Enable or disable the receiving language aspect." active = aBoolean ifTrue: [ ^ self ]. active := aBoolean. self recompile! ! !LAAspect methodsFor: 'scoping' stamp: 'lr 10/10/2008 15:10'! add: anEnvironment "Add a new scope to the receiving aspect and incrementally update all code." environments := environments copyWith: anEnvironment. self isActive ifTrue: [ self recompile: anEnvironment ]. ^ anEnvironment! ! !LAAspect methodsFor: 'scoping' stamp: 'lr 10/10/2008 15:04'! addClass: aClass ^ self add: (BrowserEnvironment new forClasses: (Array with: aClass))! ! !LAAspect methodsFor: 'scoping' stamp: 'lr 10/10/2008 15:04'! addPackage: aString ^ self add: (BrowserEnvironment new forPackageNamed: aString)! ! !LAAspect methodsFor: 'accessing' stamp: 'lr 10/10/2008 15:21'! concerns "Answer a collection of concerns." ^ concerns! ! !LAAspect methodsFor: 'accessing' stamp: 'lr 10/10/2008 15:06'! environment "Answer a a composed environment." ^ environments isEmpty ifTrue: [ BrowserEnvironment new not ] ifFalse: [ environments for: [ :first :second | first | second ] ]! ! !LAAspect methodsFor: 'accessing' stamp: 'lr 10/10/2008 15:05'! environments "Answer a collection of environments." ^ environments! ! !LAAspect methodsFor: 'initialization' stamp: 'lr 10/10/2008 15:21'! initialize active := true. pointcut := LAPointcut new. concerns := environments := #()! ! !LAAspect methodsFor: 'testing' stamp: 'lr 10/10/2008 15:01'! isActive "Answer wether the receiving aspect is active or not." ^ active! ! !LAAspect methodsFor: 'actions' stamp: 'lr 10/10/2008 15:23'! recompile "Recompile all the affected methods in the selected enviornments." self recompile: self environment! ! !LAAspect methodsFor: 'actions' stamp: 'lr 10/10/2008 14:43'! recompile: anEnvironment "Recompile all the affected methods in anEnvironment." anEnvironment classesAndSelectorsDo: [ :class :selector | class recompile: selector ]! ! LAAspect subclass: #PathAspect instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'LanguageAspects-Examples'! LAAspect subclass: #RegexpAspect instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'LanguageAspects-Examples'! Object subclass: #LAConcern instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'LanguageAspects-Core'! !LAConcern methodsFor: 'public' stamp: 'lr 10/10/2008 15:30'! apply: aNode self subclassResponsibility! ! !LAConcern methodsFor: 'weaving' stamp: 'lr 10/10/2008 15:30'! weave: aParser ^ aParser => [ :node | self apply: node ]! ! LAConcern subclass: #LAHighlighter instanceVariableNames: 'color' classVariableNames: '' poolDictionaries: '' category: 'LanguageAspects-Core'! !LAHighlighter methodsFor: 'public' stamp: 'lr 10/10/2008 15:31'! apply: aNode ^ self color! ! !LAHighlighter methodsFor: 'accessing' stamp: 'lr 10/10/2008 15:31'! color ^ color! ! !LAHighlighter methodsFor: 'accessing' stamp: 'lr 10/10/2008 15:31'! color: aColor color := aColor! ! LAConcern subclass: #LATransformer instanceVariableNames: 'block' classVariableNames: '' poolDictionaries: '' category: 'LanguageAspects-Core'! Object subclass: #LAPointcut instanceVariableNames: 'rule parser action class' classVariableNames: '' poolDictionaries: '' category: 'LanguageAspects-Core'! !LAPointcut methodsFor: 'accessing-place' stamp: 'lr 10/10/2008 15:36'! after "Insert the new parser and concern after the name rule." action := #after! ! !LAPointcut methodsFor: 'accessing-place' stamp: 'lr 10/10/2008 15:35'! around "Insert the concern around the named rule." action := #around! ! !LAPointcut methodsFor: 'accessing-place' stamp: 'lr 10/10/2008 15:36'! before "Insert the new parser and concern before the name rule." action := #before! ! !LAPointcut methodsFor: 'accessing-list' stamp: 'lr 10/10/2008 15:39'! choice "Use a choice to combine the two grammars." class := PPChoiceParser! ! !LAPointcut methodsFor: 'initialization' stamp: 'lr 9/29/2008 12:26'! initialize self after. self choice. self rule: #start. self parser: PPEpsilonParser new! ! !LAPointcut methodsFor: 'accessing' stamp: 'lr 10/10/2008 15:40'! parser: aParser "The new/replacement parser to be used." parser := aParser asParser! ! !LAPointcut methodsFor: 'accessing-place' stamp: 'lr 10/10/2008 15:36'! replace "Replace the named rule with the given parser and concern." action := #replace! ! !LAPointcut methodsFor: 'accessing' stamp: 'lr 10/10/2008 15:39'! rule: aSymbol "The name of the rule to identify." rule := aSymbol asSymbol! ! !LAPointcut methodsFor: 'accessing-list' stamp: 'lr 10/10/2008 15:39'! sequence "Use a sequence to combine the two grammars." class := PPSequenceParser! ! !LAPointcut methodsFor: 'actions' stamp: 'lr 10/10/2008 15:38'! weave: aParser concern: aConcern | original copied | original := aParser perform: rule. copied := original copy. original becomeForward: (action = #replace ifTrue: [ aConcern weave: parser ] ifFalse: [ action = #around ifTrue: [ aConcern weave: copied ] ifFalse: [ action = #before ifTrue: [ class with: (aConcern weave: parser) with: copied ] ifFalse: [ action = #after ifTrue: [ class with: copied with: (aConcern weave: parser) ] ifFalse: [ self error: 'Invalid pointcut action.' ] ] ] ])! ! TestCase subclass: #LASmalltalkParserTests instanceVariableNames: 'parser' classVariableNames: '' poolDictionaries: '' category: 'LanguageAspects-Tests'! !LASmalltalkParserTests methodsFor: 'accessing' stamp: 'lr 9/23/2008 20:44'! parser ^ parser ifNil: [ parser := LASmalltalkCompiler new ]! ! !LASmalltalkParserTests methodsFor: 'testing' stamp: 'lr 9/23/2008 20:51'! testCollections RBProgramNode allSubclasses do: [ :class | class selectors do: [ :selector | self verifySelector: selector inClass: class ] ] displayingProgress: 'Comparing methods'! ! !LASmalltalkParserTests methodsFor: 'private' stamp: 'lr 9/23/2008 21:23'! verifySelector: aSelector inClass: aClass | source original other | source := aClass sourceCodeAt: aSelector. source isNil ifTrue: [ ^ self ]. original := aClass parseTreeFor: aSelector. other := self parser parse: source asParserStream. other isFailure ifTrue: [ ^ Transcript show: 'FAILURE: '; show: other; cr; show: source; cr; cr ]. self assert: original formattedCode = other formattedCode description: source resumable: true! ! TestCase subclass: #PathAspectTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'LanguageAspects-Examples'! !PathAspectTest class methodsFor: 'initialization' stamp: 'lr 10/10/2008 15:19'! initialize PathAspect default addClass: self! ! TestCase subclass: #RegexpAspectTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'LanguageAspects-Examples'! !RegexpAspectTest class methodsFor: 'initialization' stamp: 'lr 10/10/2008 15:19'! initialize RegexpAspect default addClass: self! ! PathAspectTest initialize! RegexpAspectTest initialize!