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-literals' stamp: 'lr 10/13/2008 17:28'! charLiteral super charLiteral ==> [ :token | RBLiteralNode literalToken: token value: token value second ]! ! !LASmalltalkCompiler methodsFor: 'private' stamp: 'lr 10/13/2008 17:26'! cleanupString: aString (aString isEmpty or: [ aString first ~= $' or: [ aString last ~= $' ] ]) ifTrue: [ ^ aString ]. ^ (aString copyFrom: 2 to: aString size - 1) copyReplaceAll: '''''' with: ''''! ! !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-literals' stamp: 'lr 10/13/2008 17:16'! falseLiteral super falseLiteral ==> [ :token | RBLiteralNode literalToken: token value: false ]! ! !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-literals' stamp: 'lr 10/13/2008 17:16'! nilLiteral super nilLiteral ==> [ :token | RBLiteralNode literalToken: token value: nil ]! ! !LASmalltalkCompiler methodsFor: 'grammar-literals' stamp: 'lr 10/13/2008 17:17'! numberLiteral super numberLiteral ==> [ :token | RBLiteralNode literalToken: token value: (Number readFrom: token value) ]! ! !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-literals' stamp: 'lr 10/13/2008 17:27'! stringLiteral super stringLiteral ==> [ :token | RBLiteralNode literalToken: token value: (self cleanupString: token value) ]! ! !LASmalltalkCompiler methodsFor: 'grammar-literals' stamp: 'lr 10/13/2008 17:28'! symbolLiteral super symbolLiteral ==> [ :token | RBLiteralNode literalToken: token value: (self cleanupString: token) asSymbol ]! ! !LASmalltalkCompiler methodsFor: 'grammar-literals' stamp: 'lr 10/13/2008 17:28'! trueLiteral super trueLiteral ==> [ :token | RBLiteralNode literalToken: token value: true ]! ! !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: 'token-chars' stamp: 'lr 10/13/2008 17:06'! anyChar #any! ! !LASmalltalkParser methodsFor: 'grammar-literals' stamp: 'lr 10/13/2008 16:38'! arrayLiteral '#(' token , arrayLiteralElement star , $) token ==> [ :nodes | RBLiteralNode value: (nodes second collect: [ :each | each value ]) ]! ! !LASmalltalkParser methodsFor: 'grammar-literals' stamp: 'lr 10/13/2008 16:39'! arrayLiteralElement ^ trueLiteral / falseLiteral / nilLiteral / numberLiteral / charLiteral / stringLiteral / symbolLiteral / arrayLiteral! ! !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-chars' stamp: 'lr 10/13/2008 17:07'! barChar $_! ! !LASmalltalkParser methodsFor: '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: 'primitives' stamp: 'lr 10/13/2008 17:06'! char dollarChar , anyChar! ! !LASmalltalkParser methodsFor: 'grammar-literals' stamp: 'lr 10/13/2008 17:15'! charLiteral charToken! ! !LASmalltalkParser methodsFor: 'token' stamp: 'lr 9/23/2008 19:54'! charToken char token! ! !LASmalltalkParser methodsFor: 'token-chars' stamp: 'lr 10/13/2008 17:06'! colonChar $:! ! !LASmalltalkParser methodsFor: 'token-chars' stamp: 'lr 10/13/2008 17:06'! commaChar $,! ! !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: 'token-chars' stamp: 'lr 10/13/2008 17:06'! digitChar #digit! ! !LASmalltalkParser methodsFor: 'token-chars' stamp: 'lr 10/13/2008 17:06'! dollarChar $$! ! !LASmalltalkParser methodsFor: 'token-chars' stamp: 'lr 10/13/2008 17:06'! dotChar $.! ! !LASmalltalkParser methodsFor: 'token-chars' stamp: 'lr 10/13/2008 17:06'! doubleQuoteChar $"! ! !LASmalltalkParser methodsFor: 'token-chars' stamp: 'lr 10/13/2008 17:06'! equalChar $=! ! !LASmalltalkParser methodsFor: 'grammar' stamp: 'lr 9/23/2008 20:27'! expression assignment star , cascadeExpression! ! !LASmalltalkParser methodsFor: 'grammar-literals' stamp: 'lr 10/13/2008 17:23'! falseLiteral falseToken! ! !LASmalltalkParser methodsFor: 'token' stamp: 'lr 9/23/2008 19:54'! falseToken 'false' token! ! !LASmalltalkParser methodsFor: 'token-chars' stamp: 'lr 10/13/2008 17:06'! hashChar $#! ! !LASmalltalkParser methodsFor: 'token-chars' stamp: 'lr 10/13/2008 17:06'! hatChar $^! ! !LASmalltalkParser methodsFor: 'primitives' stamp: 'lr 10/13/2008 17:08'! identifier letterChar , wordChar star! ! !LASmalltalkParser methodsFor: 'token' stamp: 'lr 9/23/2008 19:53'! identifierToken identifier token! ! !LASmalltalkParser methodsFor: 'primitives' stamp: 'lr 10/13/2008 17:06'! keyword identifier , colonChar! ! !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: 'token-chars' stamp: 'lr 10/13/2008 17:06'! leftAngleBracketChar $! ! !LASmalltalkParser methodsFor: 'token-chars' stamp: 'lr 10/13/2008 17:06'! rightCurlyBracketChar $}! ! !LASmalltalkParser methodsFor: 'token-chars' stamp: 'lr 10/13/2008 17:06'! rightParenChar $)! ! !LASmalltalkParser methodsFor: 'token-chars' stamp: 'lr 10/13/2008 17:06'! rightSquareBracketChar $]! ! !LASmalltalkParser methodsFor: 'token-chars' stamp: 'lr 10/13/2008 17:06'! semicolonChar $;! ! !LASmalltalkParser methodsFor: 'grammar' stamp: 'lr 9/23/2008 20:00'! sequence temporaries , statements! ! !LASmalltalkParser methodsFor: 'token-chars' stamp: 'lr 10/13/2008 17:06'! singleQuoteChar $'! ! !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: 'primitives' stamp: 'lr 10/13/2008 17:09'! string singleQuoteChar , ((singleQuoteChar , singleQuoteChar) / singleQuoteChar negate) star , singleQuoteChar! ! !LASmalltalkParser methodsFor: 'grammar-literals' stamp: 'lr 10/13/2008 17:17'! stringLiteral stringToken! ! !LASmalltalkParser methodsFor: 'token' stamp: 'lr 9/23/2008 19:54'! stringToken string token! ! !LASmalltalkParser methodsFor: 'grammar-literals' stamp: 'lr 10/13/2008 17:22'! symbolLiteral hashChar , symbolToken ==> #second! ! !LASmalltalkParser methodsFor: 'token' stamp: 'lr 10/13/2008 17:21'! symbolToken unaryToken / binaryToken / multiwordToken / stringToken! ! !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 10/13/2008 17:18'! trueLiteral trueToken! ! !LASmalltalkParser methodsFor: 'token' stamp: 'lr 9/23/2008 19:54'! trueToken 'true' token! ! !LASmalltalkParser methodsFor: 'primitives' stamp: 'lr 10/13/2008 17:09'! unary identifier , colonChar 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! ! !LASmalltalkParser methodsFor: 'token-chars' stamp: 'lr 10/13/2008 17:08'! wordChar #word! ! 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: 'accessing' stamp: 'lr 10/13/2008 13:41'! pointcut "Answer the pointcut of the reciever." ^ pointcut! ! !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'! !RegexpAspect methodsFor: 'initialization' stamp: 'lr 10/13/2008 13:42'! initialize super initialize. self pointcut name: #literal; after; choice; parser: $/ asParser , $/ asParser not , $/ asParser! ! 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: 'name 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 10/13/2008 13:47'! initialize self after. self choice. self name: #start. self parser: PPEpsilonParser new! ! !LAPointcut methodsFor: 'accessing' stamp: 'lr 10/13/2008 13:46'! name: aSymbol "The name of the rule to identify." name := aSymbol asSymbol! ! !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-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/13/2008 13:46'! weave: aParser concern: aConcern | original copied | original := aParser perform: name. 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.' ] ] ] ])! ! Object subclass: #NewSpeak instanceVariableNames: '' classVariableNames: 'PredicateTokenParser UnarySelectorParser SmalltalkParser' poolDictionaries: '' category: 'LanguageAspects-Examples'! !NewSpeak methodsFor: 'as yet unclassified' stamp: 'lr 10/13/2008 16:52'! lexicalGrammar " All the lexical productions are defined in this method. This makes it rather long, but puts everything in one convenient place. " | radix fraction exponent extendedFraction extendedDigits kws commentDelimiter digit digits decimalNum radixNum num number letter specialCharacter character id identifier char characterConstant twoQuotes str string kw keyword sym symbol beginComment endComment twoDblQuotes comment binSel binarySelector assign assignment | digit := self charBetween: $0 and: $9."PredicateTokenParser new accept:[:c | c between: $0 and: $9] errorMsg: 'digit expected'." digits := self digit plus. extendedDigits := (self digit | [self letter]) plus. radix := self digits, [self char: $r] wrapper:[:ds :r | ds]. fraction := self dot, [self digits] wrapper:[:period :ds | ds]. extendedFraction := self dot, [extendedDigits] wrapper:[:period :ds | ds]. exponent := (self char: $e), [(self char: $- ) opt], [self digits] wrapper:[:e :sgn :ds | sgn isNil ifTrue:[ds] ifFalse:[sgn asString, ds]]. decimalNum := (self char: $-) opt, [self digits], [fraction opt], [exponent opt]. radixNum := radix, [(self char: $-) opt], [extendedDigits], [extendedFraction opt], [exponent opt]. num := self radixNum | [self decimalNum]. "must distinguish internal use of productions from use as tokens" number := self tokenFor: self num. letter := PredicateTokenParser new accept:[:c | SmalltalkParser isLetter: c] errorMsg: 'letter expected'. "(PredicateTokenParser new accept:[:c | c between: $A and: $Z] errorMsg: '' ) | [PredicateTokenParser new accept:[:c | c between: $a and: $z] errorMsg: 'letter expected' ]." specialCharacter := (self char: $+ ) | [self char: $/ ] | [self char: $\ ] | [self char: $* ] | [self char: $~ ] | [self char: $<] | [self char: $>] | [self char: $=] | [self char: $@ ] | [self char: $% ] | [self char: $| ] | [self char: $& ] | [self char: $? ] | [self char: $!! ] | [self char: $, ]. character := self digit | [self letter] | [self specialCharacter] | [self char: $[ ] | [self char: $] ] | [self char: ${ ] | [self char: $} ] | [self char: $( ] | [self char:$) ] | [self char: $^ ] | [self char: $; ] | [self char: $$ ] | [self char: $# ] | [self char: $: ] | [self char: $. ] | [self char: $-] | [self char: $_] | [self char: $`] "the Smalltalk grammar neglects to add - to characters, or to comments. It does add | [self char: $' ], but these are both bugs. We intend to support underscores, which Squeak insists on tirning into assignment arrows. However, we do not support these as assignments. At the moment, we do not accept them in identifiers, but this will change in time.". id := self letter, [(self letter | [self digit]) star] wrapper:[:fst :snd | fst asString, (String withAll: snd)]. identifier := self tokenFor: self id. char := (self char: $$), [self character | [self char: $' ] | [self char: $" ] | [self char:$ ]]. characterConstant := self tokenFor: self char. twoQuotes := (self char: $' ), [self char: $' ] wrapper:[:q1 : q2 | '''']. str := (self char: $' ), [self stringBody], "[(self character | [self aWhitespaceChar] | [self char: $" "] | [self twoQuotes]) star]," [self char: $'] wrapper:[:oq :es :eq | es inject:'' into:[:s : e | s, e asString]]. string := self tokenFor: self str. kw := self id, [self char: $:] wrapper:[: i :c | i, $: asString]. kws := self kw plus wrap:[:c | c inject: '' into:[:s :e | s, e]]. keyword := self tokenFor: self kw. sym := self str | [kws] | [self binSel] | [self id]. symbol := self tokenFor: self sym. commentDelimiter := self char: $". beginComment := commentDelimiter. endComment := commentDelimiter. twoDblQuotes := (self char: $" ), [self char: $" ] wrapper:[:q1 : q2 | '"']. comment := self beginComment, [self commentBody], [self endComment]. binSel := (self specialCharacter | [self char: $- ]), [self specialCharacter opt] wrapper:[:c1 :c2 | c2 isNil ifTrue:[c1 asString asSymbol] ifFalse:[(c1 asString, c2 asString) asSymbol ] "probably delay interning as symbol until later phase" ]. binarySelector := self tokenFor: self binSel. "maybe intern as symbol here" assign := (self char: $:), [self char: $=] wrapper:[:c :e | #':=']. assignment := self tokenFor: (self assign | [self char: $_]). "Temporary hack"! ! !NewSpeak methodsFor: 'as yet unclassified' stamp: 'lr 10/13/2008 16:53'! setupTokens | whitespace colon comma dollar dot equalSign hat lbracket lcurly lparen langleBracket pound rangleBracket rbracket rcurly rparen semicolon slash vbar | whitespace := self whitespace. colon := self tokenFromChar: $:. comma := self tokenFromChar: $,. dollar := self tokenFromChar: $$. dot := self tokenFromChar: $.. equalSign := self tokenFromChar:$=. hat := self tokenFromChar: $^. lbracket := self tokenFromChar: $[. lcurly := self tokenFromChar: ${. lparen := self tokenFromChar: $(. langleBracket := self tokenFromChar: $<. pound := self tokenFromChar: $#. rangleBracket := self tokenFromChar: $>. rbracket := self tokenFromChar: $]. rcurly := self tokenFromChar: $}. rparen := self tokenFromChar: $). semicolon := self tokenFromChar: $;. slash := self tokenFromChar: $/. vbar := self tokenFromChar: $|.! ! !NewSpeak methodsFor: 'as yet unclassified' stamp: 'lr 10/13/2008 16:51'! syntacticGrammar "The entire syntactic grammar for Smalltalk,with a syntax for top level classes as well" "This is a very large method, but it does allow the entire grammar to be viewed as a unit" | symbolConstant array arrayConstant tuple literal variableName unarySelector parenthesizedExpression primary unaryExpression binaryMsg binaryExpression keywordMsg keywordExpression cascadeMsg cascadedMessageExpression assignmentLHS expression returnStatement furtherStatements statementSequence statements blockParameter blockParameters varDecls temporaries codeBody block variableDecl unaryMsgPattern binaryMsgPattern keywordMsgPattern messagePattern methodBody method methodDecl category classComment classBody classSideDecl languageId classCategory classDefinition | symbolConstant := self pound, [self symbol]. array := self lparen, [(self number | [self symbol] | [self string] | [self characterConstant] | [self array]) star], [self rparen]. arrayConstant := self pound, [self array]. tuple := self lcurly, [self expression starSeparatedOrTerminatedBy: self dot], [self rcurly]. literal := self number | [self symbolConstant] | [self characterConstant] | [self string] | [self arrayConstant] | [self tuple]. variableName := self identifier. unarySelector := (UnarySelectorParser new on: self). " the one hack/flaw. See UnarySelector parser for details" parenthesizedExpression := self lparen, [self expression], [self rparen]. primary := self variableName | [self literal] | [self block] | [self parenthesizedExpression]. unaryExpression := self primary, [self unarySelector star]. binaryMsg := self binarySelector, [self unaryExpression]. binaryExpression := self unaryExpression, [self binaryMsg star]. keywordMsg := (self keyword, [self binaryExpression]) plus. keywordExpression := self binaryExpression, [self keywordMsg opt]. cascadeMsg := self semicolon, [self keywordMsg | [self binaryMsg] | [self unarySelector]]. cascadedMessageExpression := self keywordExpression, [self cascadeMsg star]. assignmentLHS := self variableName, [self assignment]. expression := self assignmentLHS star, [self cascadedMessageExpression ]. returnStatement := self hat, [self expression], [self dot opt]. furtherStatements := self dot, [self statements]. statementSequence := self expression, [self furtherStatements opt]. statements := self returnStatement | [self statementSequence] | [self empty]. blockParameter := self colon, [self variableDecl]. blockParameters := self blockParameter plus, [self vbar]. varDecls := self vbar, [self variableDecl star], [self vbar]. temporaries := self varDecls. codeBody := self temporaries opt, [self statements]. block := self lbracket, [self blockParameters opt], [self codeBody], [self rbracket]. variableDecl := self identifier. unaryMsgPattern := self unarySelector. binaryMsgPattern := self binarySelector, [self variableDecl]. keywordMsgPattern := (self keyword, [self variableDecl]) plus. messagePattern := self unaryMsgPattern | [self binaryMsgPattern] | [self keywordMsgPattern ]. methodBody := self codeBody. method := self messagePattern, [self methodBody], [self eoi]. "A method in a browser" "Top level productions for classes" methodDecl := self messagePattern, [self equalSign], [self lparen], [self methodBody], [self rparen]. category := self string, [self methodDecl star]. classComment := self whitespace, [self comment]. "A hack, to preserve comments from a complete class declaration" classBody := self lparen, [self classComment opt], [self varDecls opt], [self category star], [self rparen]. classSideDecl := self colon, [self classBody ]. languageId := self identifier. classCategory := self string opt. classDefinition := self languageId, [self classCategory], [self identifier], [self equalSign], [self identifier], [self classBody],[ self classSideDecl opt], [self eoi].! ! TestCase subclass: #LASmalltalkParserTests instanceVariableNames: 'parser' classVariableNames: '' poolDictionaries: '' category: 'LanguageAspects-Tests'! !LASmalltalkParserTests methodsFor: 'parsing' stamp: 'lr 10/13/2008 13:57'! parse: aString ^ self parse: aString rule: #start! ! !LASmalltalkParserTests methodsFor: 'parsing' stamp: 'lr 10/13/2008 13:58'! parse: aString do: aBlock ^ aBlock value: (self parse: aString)! ! !LASmalltalkParserTests methodsFor: 'parsing' stamp: 'lr 10/13/2008 15:07'! parse: aString rule: aSymbol ^ (self parser productionAt: aSymbol definition: [ self error: 'Invalid production ' , aSymbol printString ]) parse: aString asParserStream! ! !LASmalltalkParserTests methodsFor: 'parsing' stamp: 'lr 10/13/2008 13:58'! parse: aString rule: aSymbol do: aBlock ^ aBlock value: (self parse: aString rule: aSymbol)! ! !LASmalltalkParserTests methodsFor: 'accessing' stamp: 'lr 9/23/2008 20:44'! parser ^ parser ifNil: [ parser := LASmalltalkCompiler new ]! ! !LASmalltalkParserTests methodsFor: 'testing-token' stamp: 'lr 10/13/2008 17:29'! testArrayLiteral self parse: '#()' rule: #arrayLiteral do: [ :token | self assert: token isLiteral. self assert: token value = #( ) ]. self parse: '#(1)' rule: #arrayLiteral do: [ :token | self assert: token isLiteral. self assert: token value = #(1) ]. self parse: '#(1 2)' rule: #arrayLiteral do: [ :token | self assert: token isLiteral. self assert: token value = #(1 2) ]. self parse: '#(true false nil)' rule: #arrayLiteral do: [ :token | self assert: token isLiteral. self assert: token value = #(true false nil) ]. self parse: '#($a)' rule: #arrayLiteral do: [ :token | self assert: token isLiteral. self assert: token value = #($a) ]. self parse: '#(1.2)' rule: #arrayLiteral do: [ :token | self assert: token isLiteral. self assert: token value = #(1.2) ]. self parse: '#(bar)' rule: #arrayLiteral do: [ :token | self assert: token isLiteral. self assert: token value = #(bar) ]. self parse: '#(''baz'')' rule: #arrayLiteral do: [ :token | self assert: token isLiteral. self assert: token value = #('baz') ]. self parse: '#((1))' rule: #arrayLiteral do: [ :token | self assert: token isLiteral. self assert: token value = #((1)) ]. self parse: '#((1 2)(1 2 3))' rule: #arrayLiteral do: [ :token | self assert: token isLiteral. self assert: token value = #((1 2)(1 2 3)) ]! ! !LASmalltalkParserTests methodsFor: 'testing-token' stamp: 'lr 10/13/2008 15:17'! testCharLiteral self parse: '$a' rule: #charLiteral do: [ :token | self assert: token isLiteral. self assert: token value = $a ]. self parse: '$ ' rule: #charLiteral do: [ :token | self assert: token isLiteral. self assert: token value = Character space ]. self parse: '$$' rule: #charLiteral do: [ :token | self assert: token isLiteral. self assert: token value = $$ ]! ! !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: 'testing-token' stamp: 'lr 10/13/2008 15:18'! testNumberLiteral self parse: '0' rule: #numberLiteral do: [ :token | self assert: token isLiteral. self assert: token value = 0 ]. self parse: '0.1' rule: #numberLiteral do: [ :token | self assert: token isLiteral. self assert: token value = 0.1 ]. self parse: '123' rule: #numberLiteral do: [ :token | self assert: token isLiteral. self assert: token value = 123 ]. self parse: '123.456' rule: #numberLiteral do: [ :token | self assert: token isLiteral. self assert: token value = 123.456 ]! ! !LASmalltalkParserTests methodsFor: 'testing-token' stamp: 'lr 10/13/2008 15:17'! testSpecialLiteral self parse: 'true' rule: #trueLiteral do: [ :token | self assert: token isLiteral. self assert: token value = true ]. self parse: 'false' rule: #falseLiteral do: [ :token | self assert: token isLiteral. self assert: token value = false ]. self parse: 'nil' rule: #nilLiteral do: [ :token | self assert: token isLiteral. self assert: token value = nil ]! ! !LASmalltalkParserTests methodsFor: 'testing-token' stamp: 'lr 10/13/2008 15:12'! testStringLiteral self parse: '''''' rule: #stringLiteral do: [ :token | self assert: token isLiteral. self assert: token value = '' ]. self parse: '''ab''' rule: #stringLiteral do: [ :token | self assert: token isLiteral. self assert: token value = 'ab' ]. self parse: '''ab''''cd''' rule: #stringLiteral do: [ :token | self assert: token isLiteral. self assert: token value = 'ab''cd' ]! ! !LASmalltalkParserTests methodsFor: 'testing-token' stamp: 'lr 10/13/2008 15:14'! testSymbolLiteral self parse: '#foo' rule: #symbolLiteral do: [ :token | self assert: token isLiteral. self assert: token value = #foo ]. self parse: '#+' rule: #symbolLiteral do: [ :token | self assert: token isLiteral. self assert: token value = #+ ]. self parse: '#key:' rule: #symbolLiteral do: [ :token | self assert: token isLiteral. self assert: token value = #key: ]. self parse: '#key:value:' rule: #symbolLiteral do: [ :token | self assert: token isLiteral. self assert: token value = #key:value: ]. self parse: '#''testing-token''' rule: #symbolLiteral do: [ :token | self assert: token isLiteral. self assert: token value = #'testing-token' ]! ! !LASmalltalkParserTests methodsFor: 'private' stamp: 'lr 10/13/2008 13:52'! 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. Transcript show: 'PASSED: '; show: other; cr; show: source; cr; cr! ! 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! ! !RegexpAspectTest methodsFor: 'accessing' stamp: 'lr 10/13/2008 13:43'! aspect ^ RegexpAspect default! ! PathAspectTest initialize! RegexpAspectTest initialize!