SystemOrganization addCategory: #'LanguageAspects-Core'! SystemOrganization addCategory: #'LanguageAspects-Tests'! 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! ! 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! !