SystemOrganization addCategory: #'Pattern-Core'! SystemOrganization addCategory: #'Pattern-Parsing'! SystemOrganization addCategory: #'Pattern-Visitor'! SystemOrganization addCategory: #'Pattern-UI'! SystemOrganization addCategory: #'Pattern-Tests'! !ParseTreeRewriter methodsFor: '*pattern' stamp: 'lr 12/31/2003 22:34'! acceptArrayNode: anArrayNode anArrayNode forceStatements: (anArrayNode statements collect: [ :each | self visitNode: each ])! ! SmaCCScanner subclass: #PMScanner instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Parsing'! !PMScanner methodsFor: 'generated-scanner' stamp: 'lr 12/31/2003 19:42'! scan5 [self recordMatch: #(13 14). self step. currentCharacter isDigit or: [(currentCharacter between: $A and: $Z) or: [currentCharacter between: $a and: $z]]] whileTrue. currentCharacter == $: ifTrue: [^self scan6]. ^self reportLastMatch! ! !PMScanner methodsFor: 'actions' stamp: 'lr 12/3/2003 22:39'! scanBlockFrom: aToken | level first result char | self scanBackwardsFrom: aToken. level _ 1. first _ stream position. result _ WriteStream on: String new. [ stream atEnd ] whileFalse: [ char _ stream next. char == $[ ifTrue: [ level _ level + 1 ]. char == $] ifTrue: [ level _ level - 1. level isZero ifTrue: [ ^first -> result contents ] ]. result nextPut: char ]. ^nil! ! !PMScanner methodsFor: 'actions' stamp: 'lr 12/3/2003 22:39'! scanUpToEndFrom: aToken self scanBackwardsFrom: aToken. ^stream position -> stream upToEnd asString! ! !PMScanner class methodsFor: 'generated-initialization' stamp: 'lr 12/31/2003 19:42'! initializeKeywordMap keywordMap := Dictionary new. #(#(14 'false' 5) #(14 'nil' 1) #(14 'true' 3)) do: [:each | (keywordMap at: each first ifAbsentPut: [Dictionary new]) at: (each at: 2) put: each last]. ^keywordMap! ! !PMScanner class methodsFor: 'generated-comments' stamp: 'lr 12/31/2003 19:42'! scannerDefinitionComment " : [a] [n]? [A-Z] [a-zA-Z0-9]* ; : [a-zA-Z] [a-zA-Z0-9]* ; : [\-]? [0-9]+ (\. [0-9]+)? ; : \' [^\']* \' (\' [^\']* \')* ; : \: ; : \: ( \: )+ ; : [\~\-\!!\@\%\&\*\+\=\\\|\?\/\>\<\,] [\~\!!\@\%\&\*\+\=\\\|\?\/\>\<\,]? ; : \s+ ; : \$ . ; : . ;"! ! !PMScanner methodsFor: 'generated-scanner' stamp: 'lr 12/31/2003 19:42'! scan6 self recordMatch: #(17). self step. ((currentCharacter between: $A and: $Z) or: [currentCharacter between: $a and: $z]) ifTrue: [^self scan3]. ^self reportLastMatch! ! !PMScanner methodsFor: 'generated-tokens' stamp: 'lr 12/31/2003 19:42'! errorTokenId ^39! ! !PMScanner methodsFor: 'generated-scanner' stamp: 'lr 12/31/2003 19:42'! scan2 [ [self step. currentCharacter ~~ $'] whileTrue. self recordMatch: #(16). self step. currentCharacter == $'] whileTrue: []. ^self reportLastMatch! ! !PMScanner methodsFor: 'generated-scanner' stamp: 'lr 12/31/2003 19:42'! scan1 [self recordMatch: #(15). self step. currentCharacter isDigit] whileTrue. currentCharacter == $. ifTrue: [self step. currentCharacter isDigit ifTrue: [ [self recordMatch: #(15). self step. currentCharacter isDigit] whileTrue. ^self reportLastMatch]. ^self reportLastMatch]. ^self reportLastMatch! ! !PMScanner methodsFor: 'generated-scanner' stamp: 'lr 12/31/2003 19:42'! scan3 [self step. currentCharacter isDigit or: [(currentCharacter between: $A and: $Z) or: [currentCharacter between: $a and: $z]]] whileTrue. currentCharacter == $: ifTrue: [self recordMatch: #(18). self step. ((currentCharacter between: $A and: $Z) or: [currentCharacter between: $a and: $z]) ifTrue: [^self scan3]. ^self reportLastMatch]. ^self reportLastMatch! ! !PMScanner methodsFor: 'generated-scanner' stamp: 'lr 12/31/2003 19:42'! scanForToken self step. ((currentCharacter between: $A and: $Z) or: [(currentCharacter between: $b and: $h) or: [currentCharacter between: $j and: $z]]) ifTrue: [^self scan4]. (currentCharacter == $!! or: [(currentCharacter between: $% and: $&) or: [(currentCharacter between: $* and: $,) or: [currentCharacter == $/ or: [(currentCharacter between: $< and: $=) or: [(currentCharacter between: $? and: $@) or: [currentCharacter == $\ or: [currentCharacter == $~]]]]]]]) ifTrue: [self recordMatch: #(19). self step. (currentCharacter == $!! or: [(currentCharacter between: $% and: $&) or: [(currentCharacter between: $* and: $,) or: [currentCharacter == $/ or: [(currentCharacter between: $< and: $@) or: [currentCharacter == $\ or: [currentCharacter == $| or: [currentCharacter == $~]]]]]]]) ifTrue: [^self recordAndReportMatch: #(19)]. ^self reportLastMatch]. currentCharacter isDigit ifTrue: [^self scan1]. (currentCharacter isSeparator or: [currentCharacter == $ ]) ifTrue: [ [self recordMatch: #whitespace. self step. currentCharacter isSeparator or: [currentCharacter == $ ]] whileTrue. ^self reportLastMatch]. currentCharacter == $# ifTrue: [^self recordAndReportMatch: #(6)]. currentCharacter == $$ ifTrue: [self step. ^self recordAndReportMatch: #(21)]. currentCharacter == $' ifTrue: [^self scan2]. currentCharacter == $- ifTrue: [self recordMatch: #(19). self step. (currentCharacter == $!! or: [(currentCharacter between: $% and: $&) or: [(currentCharacter between: $* and: $,) or: [currentCharacter == $/ or: [(currentCharacter between: $< and: $@) or: [currentCharacter == $\ or: [currentCharacter == $| or: [currentCharacter == $~]]]]]]]) ifTrue: [^self recordAndReportMatch: #(19)]. currentCharacter isDigit ifTrue: [^self scan1]. ^self reportLastMatch]. currentCharacter == $. ifTrue: [^self recordAndReportMatch: #(12)]. currentCharacter == $: ifTrue: [^self recordAndReportMatch: #(10)]. currentCharacter == $> ifTrue: [self recordMatch: #(19). self step. (currentCharacter == $!! or: [(currentCharacter between: $% and: $&) or: [(currentCharacter between: $* and: $,) or: [currentCharacter == $/ or: [(currentCharacter between: $< and: $=) or: [(currentCharacter between: $? and: $@) or: [currentCharacter == $\ or: [currentCharacter == $| or: [currentCharacter == $~]]]]]]]]) ifTrue: [^self recordAndReportMatch: #(19)]. currentCharacter == $> ifTrue: [^self recordAndReportMatch: #(4 19)]. ^self reportLastMatch]. currentCharacter == $[ ifTrue: [^self recordAndReportMatch: #(8)]. currentCharacter == $a ifTrue: [self recordMatch: #(14). self step. (currentCharacter isDigit or: [(currentCharacter between: $a and: $m) or: [currentCharacter between: $o and: $z]]) ifTrue: [^self scan4]. (currentCharacter between: $A and: $Z) ifTrue: [^self scan5]. currentCharacter == $: ifTrue: [^self scan6]. currentCharacter == $n ifTrue: [self recordMatch: #(14). self step. (currentCharacter isDigit or: [currentCharacter between: $a and: $z]) ifTrue: [^self scan4]. (currentCharacter between: $A and: $Z) ifTrue: [^self scan5]. currentCharacter == $: ifTrue: [^self scan6]. ^self reportLastMatch]. ^self reportLastMatch]. currentCharacter == $i ifTrue: [self recordMatch: #(14). self step. (currentCharacter isDigit or: [(currentCharacter between: $A and: $Z) or: [(currentCharacter between: $a and: $e) or: [currentCharacter between: $g and: $z]]]) ifTrue: [^self scan4]. currentCharacter == $: ifTrue: [^self scan6]. currentCharacter == $f ifTrue: [self recordMatch: #(14). self step. (currentCharacter isDigit or: [(currentCharacter between: $A and: $Z) or: [currentCharacter between: $a and: $z]]) ifTrue: [^self scan4]. currentCharacter == $: ifTrue: [self recordMatch: #(2 17). self step. ((currentCharacter between: $A and: $Z) or: [currentCharacter between: $a and: $z]) ifTrue: [^self scan3]. ^self reportLastMatch]. ^self reportLastMatch]. ^self reportLastMatch]. currentCharacter == ${ ifTrue: [^self recordAndReportMatch: #(7)]. currentCharacter == $| ifTrue: [self recordMatch: #(9 19). self step. (currentCharacter == $!! or: [(currentCharacter between: $% and: $&) or: [(currentCharacter between: $* and: $,) or: [currentCharacter == $/ or: [(currentCharacter between: $< and: $@) or: [currentCharacter == $\ or: [currentCharacter == $| or: [currentCharacter == $~]]]]]]]) ifTrue: [^self recordAndReportMatch: #(19)]. ^self reportLastMatch]. currentCharacter == $} ifTrue: [^self recordAndReportMatch: #(11)]. ^self reportLastMatch! ! !PMScanner methodsFor: 'generated-tokens' stamp: 'lr 12/31/2003 19:42'! emptySymbolTokenId ^38! ! !PMScanner methodsFor: 'actions' stamp: 'lr 12/3/2003 22:36'! scanBackwardsFrom: aToken stream position: (0 max: aToken startPosition - 1). [ stream last isSeparator and: [ stream position > 0 ] ] whileTrue: [ stream position: stream position - 1 ].! ! !PMScanner methodsFor: 'generated-scanner' stamp: 'lr 12/31/2003 19:42'! scan4 [self recordMatch: #(14). self step. currentCharacter isDigit or: [(currentCharacter between: $A and: $Z) or: [currentCharacter between: $a and: $z]]] whileTrue. currentCharacter == $: ifTrue: [^self scan6]. ^self reportLastMatch! ! Object subclass: #PMNode instanceVariableNames: 'parent ' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Core'! !PMNode methodsFor: 'accessing' stamp: 'lr 12/8/2003 19:12'! parent: aNode parent _ aNode! ! !PMNode methodsFor: 'testing' stamp: 'lr 12/10/2003 09:59'! isSelector ^false! ! !PMNode methodsFor: 'testing' stamp: 'lr 12/31/2003 22:44'! isPattern ^false! ! PMNode subclass: #PMCategory instanceVariableNames: 'name functions ' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Core'! !PMCategory methodsFor: 'private-building' stamp: 'lr 12/7/2003 20:29'! install PMBuilder visit: self! ! !PMCategory methodsFor: 'accessing' stamp: 'lr 12/5/2003 20:58'! groups | groups collection | groups _ OrderedCollection new. self functions do: [ :function | collection _ groups detect: [ :each | function selector = each first selector ] ifNone: [ groups add: OrderedCollection new ]. collection add: function ]. ^groups! ! !PMCategory methodsFor: 'private-building' stamp: 'lr 12/7/2003 20:30'! reinstall self uninstall; install! ! !PMCategory methodsFor: 'utility' stamp: 'lr 12/7/2003 21:28'! findLeastGeneralClass: aCollection | remainingClasses currentClass | remainingClasses _ aCollection asOrderedCollection. currentClass _ remainingClasses removeFirst. [ remainingClasses isEmpty ] whileFalse: [ [ remainingClasses first includesBehavior: currentClass ] whileFalse: [ currentClass _ currentClass superclass ]. remainingClasses removeFirst ]. ^currentClass! ! !PMCategory methodsFor: 'actions' stamp: 'lr 12/6/2003 13:55'! refresh | categoryName classes | categoryName _ self categoryName. classes _ Smalltalk allClasses select: [ :class | class organization categories includes: categoryName ]. functions _ classes inject: OrderedCollection new into: [ :result :class | result addAll: (PMFunction allFunctionsIn: self class: class); yourself ]! ! !PMCategory methodsFor: 'private' stamp: 'lr 12/6/2003 13:50'! name: aString name _ aString. self refresh.! ! !PMCategory methodsFor: 'utility' stamp: 'lr 12/10/2003 09:48'! targetFor: aCollection "Find the least general class to be the host of aCollection of functions." ^self findLeastGeneralClass: (aCollection collect: [ :each | each target ])! ! !PMCategory methodsFor: 'private-building' stamp: 'lr 12/9/2003 10:38'! uninstall | categoryName | categoryName _ self categoryName. Smalltalk allClassesDo: [ :class | (class organization categories includes: categoryName) ifTrue: [ class removeCategory: categoryName ] ].! ! !PMCategory class methodsFor: 'instance creation' stamp: 'lr 12/4/2003 13:03'! name: aString ^self new name: aString; yourself! ! !PMCategory methodsFor: 'actions' stamp: 'lr 12/7/2003 20:31'! moveDown: aFunction | index | index _ functions indexOf: aFunction. (index between: 1 and: functions size - 1) ifTrue: [ self functions swap: index with: index + 1. self reinstall ]! ! !PMCategory methodsFor: 'comparing' stamp: 'lr 12/5/2003 21:13'! hash ^name hash! ! !PMCategory methodsFor: 'accessing' stamp: 'lr 12/4/2003 13:02'! name ^name! ! !PMCategory class methodsFor: 'private' stamp: 'lr 12/7/2003 20:09'! categoryPostfix ^'-Functional'! ! !PMCategory methodsFor: 'accessing' stamp: 'lr 12/5/2003 20:43'! functions ^functions! ! !PMCategory methodsFor: 'comparing' stamp: 'lr 12/5/2003 21:14'! = anObject ^self class = anObject class and: [ self name = anObject name ]! ! !PMCategory methodsFor: 'actions' stamp: 'lr 12/10/2003 10:44'! add: aFunction "Add a function to the receiver and return true if the function has been added or false if the function has replaced an existing one." | index | aFunction parent: self. index _ self functions findFirst: [ :each | aFunction = each ]. index isZero ifTrue: [ functions addLast: aFunction ] ifFalse: [ functions at: index put: aFunction ]. self reinstall. ^index isZero! ! !PMCategory methodsFor: 'actions' stamp: 'lr 12/7/2003 20:31'! moveUp: aFunction | index | index _ functions indexOf: aFunction. (index between: 2 and: functions size) ifTrue: [ self functions swap: index with: index - 1. self reinstall ]! ! !PMCategory methodsFor: 'actions' stamp: 'lr 12/8/2003 22:08'! remove: aFunction self functions remove: aFunction. self reinstall.! ! !PMCategory methodsFor: 'actions' stamp: 'lr 12/9/2003 10:37'! renameTo: aString | oldCategoryName newCategoryName | oldCategoryName _ self categoryName. self name: aString. newCategoryName _ self categoryName. Smalltalk allClassesDo: [ :class | (class organization categories includes: oldCategoryName) ifTrue: [ class organization renameCategory: oldCategoryName toBe: newCategoryName ] ].! ! !PMCategory methodsFor: 'visiting' stamp: 'lr 12/2/2003 19:12'! acceptVisitor: aVisitor aVisitor visitCategory: self! ! !PMCategory class methodsFor: 'accessing' stamp: 'lr 12/4/2003 13:13'! allCategories | categories | categories _ Smalltalk allClasses gather: [ :class | class organization categories select: [ :symbol | symbol endsWith: self categoryPostfix ] ]. ^categories asSet collect: [ :each | self name: (each copyFrom: self categoryPrefix size + 1 to: each size - self categoryPostfix size) ]! ! !PMCategory class methodsFor: 'private' stamp: 'lr 12/4/2003 13:12'! categoryPrefix ^'*'! ! !PMCategory methodsFor: 'accessing' stamp: 'lr 12/6/2003 13:22'! categoryName ^String streamContents: [ :stream | stream nextPutAll: self class categoryPrefix; nextPutAll: self name; nextPutAll: self class categoryPostfix ]! ! !PMCategory methodsFor: 'actions' stamp: 'lr 12/8/2003 22:09'! removeAll self uninstall; refresh ! ! PMNode subclass: #PMExpression instanceVariableNames: 'source node ' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Core'! !PMExpression methodsFor: 'accessing' stamp: 'lr 12/4/2003 17:35'! node ^node! ! !PMExpression methodsFor: 'accessing' stamp: 'lr 12/3/2003 21:56'! source: aString source _ aString! ! !PMExpression class methodsFor: 'instance creation' stamp: 'lr 12/4/2003 17:35'! source: aString node: aNode ^self new source: aString; node: aNode; yourself! ! !PMExpression methodsFor: 'accessing' stamp: 'lr 12/3/2003 21:56'! source ^source! ! !PMExpression methodsFor: 'comparing' stamp: 'lr 12/5/2003 21:51'! hash ^self node hash! ! !PMExpression methodsFor: 'accessing' stamp: 'lr 12/4/2003 17:38'! node: aNode node _ aNode! ! !PMExpression methodsFor: 'comparing' stamp: 'lr 12/5/2003 21:51'! = anObject ^self class = anObject class and: [ self node = anObject node ]! ! !PMExpression methodsFor: 'visiting' stamp: 'lr 12/3/2003 21:57'! acceptVisitor: aVisitor aVisitor visitExpression: self.! ! PMNode subclass: #PMPattern instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Core'! !PMPattern methodsFor: 'testing' stamp: 'lr 12/10/2003 10:00'! isReceiver ^self parent isSelector not! ! !PMPattern methodsFor: 'visiting' stamp: 'lr 12/1/2003 23:13'! acceptVisitor: aVisitor aVisitor visitPattern: self! ! PMPattern subclass: #PMVariablePattern instanceVariableNames: 'name ' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Core'! !PMVariablePattern methodsFor: 'accessing' stamp: 'lr 12/1/2003 21:41'! name: aString name _ aString! ! !PMVariablePattern methodsFor: 'tools' stamp: 'lr 12/10/2003 09:49'! target ^Object! ! !PMVariablePattern class methodsFor: 'instance-creation' stamp: 'lr 12/1/2003 21:43'! name: aString ^self new name: aString; yourself! ! !PMVariablePattern methodsFor: 'accessing' stamp: 'lr 12/1/2003 21:41'! name ^name! ! !PMVariablePattern methodsFor: 'visiting' stamp: 'lr 12/1/2003 23:14'! acceptVisitor: aVisitor aVisitor visitVariablePattern: self! ! PMVariablePattern subclass: #PMBlockPattern instanceVariableNames: 'expression ' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Core'! !PMBlockPattern methodsFor: 'accessing' stamp: 'lr 12/8/2003 19:16'! expression: anExpression anExpression parent: self. expression _ anExpression.! ! !PMBlockPattern methodsFor: 'visiting' stamp: 'lr 12/4/2003 10:18'! acceptVisitor: aVisitor aVisitor visitBlockPattern: self! ! !PMBlockPattern class methodsFor: 'instance-creation' stamp: 'lr 12/4/2003 10:21'! name: aString expression: aNode ^(self name: aString) expression: aNode; yourself! ! !PMBlockPattern methodsFor: 'comparing' stamp: 'lr 12/5/2003 22:42'! hash ^self expression hash! ! !PMBlockPattern methodsFor: 'comparing' stamp: 'lr 12/31/2003 16:56'! = anObject ^super = anObject and: [ self expression = anObject expression ]! ! !PMBlockPattern methodsFor: 'accessing' stamp: 'lr 12/4/2003 10:17'! expression ^expression! ! PMVariablePattern subclass: #PMClassPattern instanceVariableNames: 'target ' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Core'! !PMClassPattern methodsFor: 'accessing' stamp: 'lr 12/9/2003 19:40'! name: aString "Extract the class name from aString, where any prefix like 'a' or 'an' and postfix consiting of digitis are removed." | className | super name: aString. className _ aString allButFirst. className first = $n ifTrue: [ className _ className allButFirst ]. [ className notEmpty and: [ className last isDigit ] ] whileTrue: [ className _ className allButLast ]. self target: (Smalltalk at: className asSymbol ifAbsent: [ Object ])! ! !PMClassPattern methodsFor: 'comparing' stamp: 'lr 12/5/2003 22:42'! hash ^self target hash! ! !PMClassPattern methodsFor: 'accessing' stamp: 'lr 12/5/2003 21:08'! target: aClass target _ aClass! ! !PMClassPattern methodsFor: 'comparing' stamp: 'lr 12/31/2003 16:56'! = anObject ^super = anObject and: [ self target = anObject target ]! ! !PMClassPattern methodsFor: 'visiting' stamp: 'lr 12/1/2003 23:14'! acceptVisitor: aVisitor aVisitor visitClassPattern: self! ! !PMClassPattern methodsFor: 'accessing' stamp: 'lr 12/5/2003 21:07'! target ^target! ! PMPattern subclass: #PMObjectPattern instanceVariableNames: 'object ' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Core'! !PMObjectPattern methodsFor: 'visiting' stamp: 'lr 12/1/2003 23:14'! acceptVisitor: aVisitor aVisitor visitObjectPattern: self! ! !PMObjectPattern methodsFor: 'testing' stamp: 'lr 12/8/2003 20:44'! isLiteral ^self object class ~= String and: [ self object isLiteral or: [ self object isKindOf: Boolean ] ]! ! !PMObjectPattern methodsFor: 'tools' stamp: 'lr 12/10/2003 09:49'! target ^self object class! ! !PMObjectPattern methodsFor: 'comparing' stamp: 'lr 12/31/2003 16:55'! = anObject ^super = anObject and: [ self object = anObject object ]! ! !PMObjectPattern class methodsFor: 'instance creation' stamp: 'lr 12/1/2003 21:15'! object: anObject ^self new object: anObject yourself! ! !PMObjectPattern methodsFor: 'accessing' stamp: 'lr 12/1/2003 19:48'! object ^object! ! !PMObjectPattern methodsFor: 'accessing' stamp: 'lr 12/1/2003 19:47'! object: anObject object _ anObject! ! !PMObjectPattern methodsFor: 'comparing' stamp: 'lr 12/5/2003 21:16'! hash ^self object hash! ! !PMPattern methodsFor: 'tools' stamp: 'lr 12/10/2003 09:48'! target self subclassResponsibility! ! !PMPattern methodsFor: 'testing' stamp: 'lr 12/4/2003 17:15'! hasName ^self name notNil! ! !PMPattern methodsFor: 'comparing' stamp: 'lr 12/31/2003 16:54'! = anObject ^self class = anObject class and: [ self name = anObject name ]! ! !PMPattern methodsFor: 'comparing' stamp: 'lr 12/31/2003 16:54'! hash ^self name hash! ! PMPattern subclass: #PMListPattern instanceVariableNames: 'items ' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Core'! !PMListPattern class methodsFor: 'instance-creation' stamp: 'lr 12/8/2003 18:32'! empty ^self new! ! !PMListPattern methodsFor: 'accessing-items' stamp: 'lr 12/8/2003 18:31'! addAll: aCollection aCollection do: [ :each | self add: each ]! ! !PMListPattern methodsFor: 'visiting' stamp: 'lr 12/1/2003 23:14'! acceptVisitor: aVisitor aVisitor visitListPattern: self! ! !PMListPattern methodsFor: 'accessing-items' stamp: 'lr 12/8/2003 20:49'! size ^items size! ! !PMListPattern methodsFor: 'comparing' stamp: 'lr 12/8/2003 18:20'! hash ^self items hash! ! !PMListPattern methodsFor: 'tools' stamp: 'lr 12/10/2003 09:49'! target ^SequenceableCollection! ! !PMListPattern methodsFor: 'testing' stamp: 'lr 12/8/2003 18:20'! isEmpty ^items isEmpty! ! !PMListPattern methodsFor: 'initialization' stamp: 'lr 12/8/2003 18:31'! initialize super initialize. items _ OrderedCollection new.! ! PMListPattern subclass: #PMOpenListPattern instanceVariableNames: 'tail ' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Core'! !PMOpenListPattern methodsFor: 'testing' stamp: 'lr 12/8/2003 22:41'! hasTail ^true! ! !PMOpenListPattern methodsFor: 'comparing' stamp: 'lr 12/8/2003 18:32'! hash ^super hash bitXor: [ self tail ]! ! !PMOpenListPattern class methodsFor: 'instance-creation' stamp: 'lr 12/8/2003 18:35'! head: aCollection tail: aPattern ^(self head: aCollection) tail: aPattern; yourself! ! !PMOpenListPattern methodsFor: 'accessing' stamp: 'lr 12/8/2003 19:11'! tail: aPattern aPattern parent: self. tail _ aPattern.! ! !PMOpenListPattern methodsFor: 'accessing' stamp: 'lr 12/8/2003 18:22'! tail ^tail! ! !PMOpenListPattern methodsFor: 'visiting' stamp: 'lr 12/8/2003 18:25'! acceptVisitor: aVisitor aVisitor visitOpenListPattern: self! ! !PMOpenListPattern methodsFor: 'comparing' stamp: 'lr 12/8/2003 22:50'! = anObject ^super = anObject and: [ self tail = anObject tail ]! ! !PMListPattern class methodsFor: 'instance-creation' stamp: 'lr 12/8/2003 18:35'! head: aCollection ^self empty addAll: aCollection; yourself! ! !PMListPattern methodsFor: 'comparing' stamp: 'lr 12/31/2003 16:55'! = anObject ^super = anObject and: [ self items = anObject items ]! ! !PMListPattern methodsFor: 'accessing' stamp: 'lr 12/8/2003 18:19'! items: aCollection items _ aCollection! ! !PMListPattern methodsFor: 'testing' stamp: 'lr 12/8/2003 22:41'! hasTail ^false! ! !PMListPattern methodsFor: 'accessing' stamp: 'lr 12/8/2003 18:19'! items ^items! ! !PMListPattern methodsFor: 'accessing-items' stamp: 'lr 12/8/2003 19:10'! add: aPattern aPattern parent: self. items addLast: aPattern.! ! !PMPattern methodsFor: 'testing' stamp: 'lr 12/31/2003 22:44'! isPattern ^true! ! !PMPattern methodsFor: 'tools' stamp: 'lr 12/4/2003 17:16'! name ^nil! ! !PMNode methodsFor: 'initialization' stamp: 'lr 12/2/2003 08:39'! initialize ! ! PMNode subclass: #PMFunction instanceVariableNames: 'receiver arguments condition body mapping ' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Core'! !PMFunction methodsFor: 'testing' stamp: 'lr 12/2/2003 09:27'! hasCondition ^condition notNil! ! !PMFunction methodsFor: 'initialization' stamp: 'lr 12/31/2003 16:30'! setReceiver: aPattern arguments: aCollection condition: aConditionNode body: aBodyNode receiver _ aPattern parent: self. arguments _ aCollection collect: [ :each | each parent: self ]. condition _ aConditionNode isNil ifFalse: [ aConditionNode parent: self ]. body _ aBodyNode parent: self. mapping _ self buildArgumentMapping.! ! !PMFunction methodsFor: 'accessing' stamp: 'lr 12/2/2003 10:14'! condition ^condition! ! !PMFunction methodsFor: 'printing' stamp: 'lr 12/4/2003 10:13'! asText ^Text streamContents: [ :stream | PMFunctionPrinter print: self on: stream ]! ! !PMFunction methodsFor: 'printing' stamp: 'lr 12/4/2003 10:02'! printOn: aStream PMSelectorPrinter print: self on: aStream! ! !PMFunction methodsFor: 'testing' stamp: 'lr 12/2/2003 19:32'! hasBody ^body notNil! ! !PMFunction class methodsFor: 'configuration' stamp: 'lr 12/4/2003 20:40'! argumentPrefix ^'t'! ! !PMFunction methodsFor: 'utility' stamp: 'lr 12/5/2003 00:07'! numArgs ^self hasArguments ifTrue: [ arguments size ] ifFalse: [ 0 ]! ! !PMFunction methodsFor: 'accessing' stamp: 'lr 12/1/2003 20:14'! body ^body! ! !PMFunction methodsFor: 'printing' stamp: 'lr 12/4/2003 10:13'! asString ^String streamContents: [ :stream | PMFunctionPrinter print: self on: stream ]! ! !PMFunction class methodsFor: 'instance creation' stamp: 'lr 12/31/2003 16:19'! receiver: aPattern arguments: aCollection condition: aConditionNode body: aBodyNode ^self new setReceiver: aPattern arguments: aCollection condition: aConditionNode body: aBodyNode; yourself! ! !PMFunction methodsFor: 'utility' stamp: 'lr 12/2/2003 12:14'! selector | selector | selector _ arguments inject: String new into: [ :string :each | string , each selector ]. ^selector asSymbol! ! !PMFunction methodsFor: 'accessing' stamp: 'lr 12/31/2003 16:22'! mapping ^mapping! ! !PMFunction class methodsFor: 'accessing' stamp: 'lr 12/6/2003 16:39'! allFunctionsIn: aCategory class: aClass | result selectors source parsed function | result _ OrderedCollection new. selectors _ aClass organization listAtCategoryNamed: aCategory categoryName. selectors do: [ :selector | source _ aClass sourceCodeAt: selector ifAbsent: [ String new ]. source notNil ifTrue: [ parsed _ RBParser parseMethod: source onError: [ :string :position | nil ]. parsed notNil ifTrue: [ function _ String new. parsed comments do: [ :interval | function _ function , (parsed source copyFrom: interval first + 1 to: interval last). (parsed source at: interval last + 1) = $" ifFalse: [ result add: (PMParser parse: function allButLast). function _ String new ] ] ] ] ]. ^result! ! !PMFunction methodsFor: 'comparing' stamp: 'lr 12/5/2003 21:50'! hash ^receiver hash bitXor: (arguments hash bitXor: condition hash)! ! !PMFunction methodsFor: 'testing' stamp: 'lr 12/2/2003 19:34'! hasArguments ^arguments first isMatched! ! !PMFunction class methodsFor: 'instance creation' stamp: 'lr 12/31/2003 16:19'! receiver: aPattern arguments: aCollection body: aBodyNode ^self receiver: aPattern arguments: aCollection condition: nil body: aBodyNode! ! !PMFunction methodsFor: 'utility' stamp: 'lr 12/4/2003 20:42'! argumentNames ^(1 to: self numArgs) collect: [ :each | self class argumentPrefix , each asString ]! ! !PMFunction methodsFor: 'accessing' stamp: 'lr 12/1/2003 19:15'! arguments ^arguments! ! !PMFunction methodsFor: 'private' stamp: 'lr 12/31/2003 16:42'! buildArgumentMapping ^(PMArgumentMapper visit: self) mapping! ! !PMFunction methodsFor: 'accessing' stamp: 'lr 12/2/2003 19:56'! receiver ^receiver! ! !PMFunction class methodsFor: 'configuration' stamp: 'lr 12/9/2003 20:36'! template ^PMParser parse: 'receiverPattern>>selector: argumentPattern if: [ condition statements ] "comment stating purpose of function" | temporary variable names | statements'! ! !PMFunction methodsFor: 'visiting' stamp: 'lr 12/2/2003 19:32'! acceptVisitor: aVisitor aVisitor visitFunction: self! ! !PMFunction methodsFor: 'utility' stamp: 'lr 12/10/2003 09:48'! target ^self receiver target! ! !PMFunction methodsFor: 'comparing' stamp: 'lr 12/5/2003 21:49'! = anObject ^self class = anObject class and: [ self receiver = anObject receiver ] and: [ self arguments = anObject arguments ] and: [ self condition = anObject condition ]! ! !PMFunction methodsFor: 'printing' stamp: 'lr 12/4/2003 21:36'! asComment | read | read _ self asString readStream. ^String streamContents: [ :stream | [ read atEnd ] whileFalse: [ stream nextPut: $". stream nextPutAll: (read upTo: $"). stream nextPut: $" ] ] ! ! PMNode subclass: #PMSelector instanceVariableNames: 'selector ' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Core'! !PMSelector methodsFor: 'comparing' stamp: 'lr 12/5/2003 21:18'! hash ^self selector hash! ! !PMSelector methodsFor: 'testing' stamp: 'lr 12/2/2003 19:33'! isMatched ^false! ! !PMSelector methodsFor: 'testing' stamp: 'lr 12/10/2003 10:00'! isSelector ^true! ! !PMSelector class methodsFor: 'instance creation' stamp: 'lr 12/2/2003 08:49'! selector: aSymbol ^self new selector: aSymbol; yourself! ! !PMSelector methodsFor: 'visiting' stamp: 'lr 12/2/2003 08:58'! acceptVisitor: aVisitor aVisitor visitSelector: self! ! !PMSelector methodsFor: 'comparing' stamp: 'lr 12/5/2003 21:18'! = anObject ^self class = anObject class and: [ self selector = anObject selector ]! ! !PMSelector methodsFor: 'accessing' stamp: 'lr 12/2/2003 08:43'! selector: aSymbol selector _ aSymbol! ! PMSelector subclass: #PMMatchedSelector instanceVariableNames: 'pattern ' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Core'! !PMMatchedSelector methodsFor: 'visiting' stamp: 'lr 12/2/2003 09:13'! acceptVisitor: aVisitor aVisitor visitMatchedSelector: self! ! !PMMatchedSelector methodsFor: 'testing' stamp: 'lr 12/2/2003 19:34'! isMatched ^true! ! !PMMatchedSelector class methodsFor: 'instance creation' stamp: 'lr 12/2/2003 08:55'! selector: aSymbol pattern: aPattern ^(self selector: aSymbol) pattern: aPattern; yourself! ! !PMMatchedSelector methodsFor: 'comparing' stamp: 'lr 12/5/2003 21:19'! = anObject ^self class = anObject class and: [ self selector = anObject selector ] and: [ self pattern = anObject pattern ]! ! !PMMatchedSelector methodsFor: 'comparing' stamp: 'lr 12/5/2003 21:19'! hash ^self selector hash bitXor: self pattern hash! ! !PMMatchedSelector methodsFor: 'accessing' stamp: 'lr 12/8/2003 19:17'! pattern: aPattern aPattern parent: self. pattern _ aPattern.! ! !PMMatchedSelector methodsFor: 'accessing' stamp: 'lr 12/2/2003 08:51'! pattern ^pattern! ! !PMSelector methodsFor: 'accessing' stamp: 'lr 12/2/2003 08:43'! selector ^selector! ! !PMNode class methodsFor: 'instance creation' stamp: 'lr 12/2/2003 08:39'! new ^super new initialize; yourself! ! !PMNode methodsFor: 'accessing' stamp: 'lr 12/8/2003 19:12'! parent ^parent! ! !PMNode methodsFor: 'visiting' stamp: 'lr 12/2/2003 08:40'! acceptVisitor: aVisitor self subclassResponsibility! ! Object subclass: #PMMock instanceVariableNames: 'message ' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Tests'! !PMMock methodsFor: 'private' stamp: 'lr 12/7/2003 20:13'! doesNotUnderstand: aMessage message _ aMessage! ! !PMMock methodsFor: 'accessing' stamp: 'lr 12/7/2003 20:13'! message ^message! ! Object subclass: #PMVisitor instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Visitor'! !PMVisitor methodsFor: 'visiting' stamp: 'lr 12/2/2003 19:13'! visitCategory: aCategory self visitAll: aCategory functions! ! !PMVisitor class methodsFor: 'instance creation' stamp: 'lr 12/1/2003 23:16'! new ^super new initialize; yourself! ! PMVisitor subclass: #PMBuilder instanceVariableNames: 'target methodNode category function ' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Visitor'! !PMBuilder methodsFor: 'building' stamp: 'lr 12/10/2003 09:53'! buildFunctionMatcher ^(PMConditionBuilder target: target visit: function) condition! ! !PMBuilder methodsFor: 'visiting' stamp: 'lr 12/10/2003 09:52'! visitCategory: aCategory category _ aCategory. category groups do: [ :group | function _ group first. target _ aCategory targetFor: group. self buildMethod: group ]! ! !PMBuilder methodsFor: 'building' stamp: 'lr 12/10/2003 09:52'! buildMethod: aCollection self buildMethodNode. self visitAll: aCollection. self buildMethodEnd. target compile: methodNode formattedCode. target organization classify: function selector under: category categoryName.! ! !PMBuilder methodsFor: 'building' stamp: 'lr 12/5/2003 22:18'! buildFunctionBody ^RBBlockNode body: (self buildFunctionBlock)! ! !PMBuilder methodsFor: 'building' stamp: 'lr 12/5/2003 22:21'! buildFunction | index | index _ methodNode source size + 1. methodNode source: methodNode source , function asComment. methodNode comments add: (index to: methodNode source size). ^RBMessageNode receiver: (self buildFunctionMatcher) selector: #ifTrue: arguments: {self buildFunctionBody}! ! !PMBuilder methodsFor: 'building' stamp: 'lr 12/6/2003 16:30'! buildFunctionBlock | result | result _ RBSequenceNode statements: { function body node }. result lastIsReturn ifFalse: [ result addSelfReturn ]. ^result! ! !PMBuilder methodsFor: 'building' stamp: 'lr 12/5/2003 22:24'! buildMethodNode methodNode _ RBMethodNode selector: function selector arguments: (self buildMethodArguments) body: (RBSequenceNode statements: OrderedCollection new). ^methodNode comments: OrderedCollection new; source: String new; yourself! ! !PMBuilder methodsFor: 'building' stamp: 'lr 12/5/2003 22:16'! buildMethodArguments ^function argumentNames collect: [ :each | RBVariableNode named: each ]! ! !PMBuilder methodsFor: 'building' stamp: 'lr 12/6/2003 16:32'! buildMethodEnd methodNode addNode: (RBReturnNode value: (RBMessageNode receiver: (RBVariableNode named: 'self') selector: #doesNotUnderstand: arguments: {RBMessageNode receiver: (RBVariableNode named: 'Message') selector: #selector:arguments: arguments: { RBLiteralNode value: function selector. RBArrayNode leftBrace: nil rightBrace: nil statements: (self buildMethodArguments) }})); removeDeadCode. methodNode body nodesDo: [ :each | each comments: nil ].! ! !PMBuilder methodsFor: 'visiting' stamp: 'lr 12/5/2003 22:21'! visitFunction: aFunction function _ aFunction. methodNode addNode: self buildFunction! ! !PMVisitor methodsFor: 'visiting' stamp: 'lr 12/8/2003 18:48'! visitListPattern: aPattern self visitPattern: aPattern. self visitAll: aPattern items.! ! !PMVisitor methodsFor: 'visiting' stamp: 'lr 12/2/2003 09:06'! visitSelector: aSelector! ! PMVisitor subclass: #PMPrinter instanceVariableNames: 'stream ' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Visitor'! !PMPrinter methodsFor: 'accessing' stamp: 'lr 12/4/2003 10:03'! contents ^self stream contents! ! !PMPrinter class methodsFor: 'instance creation' stamp: 'lr 12/4/2003 10:02'! print: aNode on: aStream ^self new stream: aStream; visit: aNode; yourself! ! !PMPrinter methodsFor: 'private' stamp: 'lr 12/4/2003 10:02'! stream: aStream stream _ aStream! ! PMPrinter subclass: #PMSelectorPrinter instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Visitor'! !PMSelectorPrinter methodsFor: 'visiting' stamp: 'lr 12/2/2003 09:13'! visitMatchedSelector: aSelector stream nextPutAll: aSelector selector; space. self visit: aSelector pattern.! ! !PMSelectorPrinter methodsFor: 'visiting' stamp: 'lr 1/1/2004 00:21'! visitOpenListPattern: aPattern self visitListPattern: aPattern. stream skip: -1. aPattern items last target = Symbol ifTrue: [ stream nextPut: $. ]. stream nextPut: $|. self visit: aPattern tail. stream nextPut: $}.! ! PMSelectorPrinter subclass: #PMFunctionPrinter instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Visitor'! !PMFunctionPrinter methodsFor: 'visiting' stamp: 'lr 12/4/2003 10:07'! visitFunction: aFunction stream withAttribute: TextEmphasis bold do: [ super visitFunction: aFunction ]. aFunction hasCondition ifTrue: [ stream withAttribute: TextEmphasis italic do: [ stream cr; tab; nextPutAll: 'if: ['. self visit: aFunction condition. stream nextPut: $] ] ]. self visit: aFunction body.! ! !PMSelectorPrinter methodsFor: 'visiting' stamp: 'lr 12/8/2003 19:20'! visitListPattern: aPattern stream nextPut: ${. self visitAll: aPattern items separatedBy: [ stream nextPutAll: '. ' ]. stream nextPut: $}.! ! !PMSelectorPrinter methodsFor: 'visiting' stamp: 'lr 12/3/2003 22:02'! visitSelector: aSelector stream nextPutAll: aSelector selector.! ! !PMSelectorPrinter methodsFor: 'visiting' stamp: 'lr 12/4/2003 10:37'! visitBlockPattern: aPattern stream nextPutAll: '[ :'. self visitVariablePattern: aPattern. stream nextPutAll: ' |'. self visit: aPattern expression. stream nextPut: $].! ! !PMSelectorPrinter methodsFor: 'visiting' stamp: 'lr 12/2/2003 09:16'! visitVariablePattern: aPattern stream nextPutAll: aPattern name.! ! !PMSelectorPrinter methodsFor: 'visiting' stamp: 'lr 12/2/2003 09:15'! visitObjectPattern: aPattern stream print: aPattern object.! ! !PMSelectorPrinter methodsFor: 'visiting' stamp: 'lr 12/3/2003 22:02'! visitExpression: anExpression stream nextPutAll: anExpression source.! ! !PMSelectorPrinter methodsFor: 'visiting' stamp: 'lr 12/4/2003 10:06'! visitFunction: aFunction self visit: aFunction receiver. stream nextPutAll: '>>'. self visitAll: aFunction arguments separatedBy: [ stream space ].! ! !PMPrinter methodsFor: 'private' stamp: 'lr 12/4/2003 10:03'! stream ^stream! ! !PMVisitor methodsFor: 'visiting' stamp: 'lr 12/4/2003 17:14'! visitPattern: aPattern! ! !PMVisitor methodsFor: 'initialization' stamp: 'lr 12/1/2003 23:16'! initialize ! ! !PMVisitor class methodsFor: 'instance creation' stamp: 'lr 12/2/2003 19:10'! visit: aNode ^self new visit: aNode; yourself! ! !PMVisitor methodsFor: 'visiting' stamp: 'lr 12/3/2003 21:59'! visitExpression: anExpression! ! !PMVisitor methodsFor: 'visiting' stamp: 'lr 12/1/2003 23:11'! visitClassPattern: aPattern self visitVariablePattern: aPattern.! ! !PMVisitor methodsFor: 'utility' stamp: 'lr 12/1/2003 23:12'! visitAll: aCollection aCollection do: [ :each | each acceptVisitor: self ].! ! !PMVisitor methodsFor: 'visiting' stamp: 'lr 12/4/2003 10:25'! visitBlockPattern: aPattern self visitVariablePattern: aPattern.! ! !PMVisitor methodsFor: 'utility' stamp: 'lr 12/1/2003 23:18'! visitAll: aCollection separatedBy: aBlock aCollection do: [ :each | each acceptVisitor: self ] separatedBy: aBlock! ! !PMVisitor methodsFor: 'visiting' stamp: 'lr 12/8/2003 18:48'! visitOpenListPattern: aPattern self visitListPattern: aPattern. self visit: aPattern tail.! ! !PMVisitor methodsFor: 'visiting' stamp: 'lr 12/2/2003 09:06'! visitVariablePattern: aPattern self visitPattern: aPattern.! ! PMVisitor subclass: #PMStackedVisitor instanceVariableNames: 'stack ' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Visitor'! PMStackedVisitor subclass: #PMArgumentMapper instanceVariableNames: 'mapping expressions ' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Visitor'! !PMArgumentMapper methodsFor: 'private' stamp: 'lr 12/31/2003 15:50'! defineMapping: aString | key | key _ RBVariableNode named: aString. (self mapping includesKey: key) ifFalse: [ self mapping at: key put: OrderedCollection new ]. (self mapping at: key) addLast: self top! ! !PMArgumentMapper methodsFor: 'visiting' stamp: 'lr 12/8/2003 22:37'! visitOpenListPattern: aPattern self visitListPattern: aPattern. super visitOpenListPattern: aPattern. ! ! !PMArgumentMapper methodsFor: 'visiting' stamp: 'lr 12/8/2003 22:16'! visitFunction: aFunction super visitFunction: aFunction. self visit: aFunction condition. self visit: aFunction body. self applyMapping.! ! !PMArgumentMapper methodsFor: 'visiting' stamp: 'lr 12/8/2003 21:25'! visitVariablePattern: aPattern self defineMapping: aPattern name! ! !PMArgumentMapper methodsFor: 'visiting' stamp: 'lr 12/8/2003 20:00'! visitBlockPattern: aPattern self visitVariablePattern: aPattern. self visit: aPattern expression.! ! !PMArgumentMapper methodsFor: 'visiting' stamp: 'lr 12/8/2003 20:15'! visitExpression: anExpression expressions add: anExpression! ! !PMArgumentMapper methodsFor: 'private' stamp: 'lr 12/31/2003 21:42'! applyMapping | rewriter | mapping keysAndValuesDo: [ :source :target | rewriter _ ParseTreeRewriter new. rewriter replaceTree: source withTree: target first. expressions do: [ :each | (rewriter executeTree: each node) ifTrue: [ each node: rewriter tree ] ] ]! ! !PMArgumentMapper methodsFor: 'accessing' stamp: 'lr 12/4/2003 22:37'! mapping ^mapping! ! !PMArgumentMapper methodsFor: 'initialization' stamp: 'lr 12/8/2003 20:19'! initialize super initialize. mapping _ Dictionary new. expressions _ OrderedCollection new.! ! !PMStackedVisitor methodsFor: 'visiting' stamp: 'lr 12/8/2003 22:35'! visitListPattern: aPattern aPattern items withIndexDo: [ :each :pos | self pushSelector: #at: argument: pos do: [ self visit: each ] ]! ! !PMStackedVisitor methodsFor: 'private' stamp: 'lr 12/8/2003 22:58'! pushSelector: aSymbol argument: aValue do: aBlock self push: (RBMessageNode receiver: self top selector: aSymbol arguments: {RBLiteralNode value: aValue}) do: aBlock ! ! !PMStackedVisitor methodsFor: 'utility' stamp: 'lr 12/8/2003 22:13'! removeAll stack _ OrderedCollection new.! ! !PMStackedVisitor methodsFor: 'initialization' stamp: 'lr 12/8/2003 22:13'! initialize super initialize. self removeAll.! ! !PMStackedVisitor methodsFor: 'utility' stamp: 'lr 12/8/2003 21:53'! top ^stack last copy! ! !PMStackedVisitor methodsFor: 'visiting' stamp: 'lr 12/8/2003 22:16'! visitFunction: aFunction self initialize. self pushVariable: 'self' do: [ self visit: aFunction receiver ]. aFunction arguments withIndexDo: [ :each :index | self pushVariable: 't' , index asString do: [ self visit: each ] ].! ! !PMStackedVisitor methodsFor: 'private' stamp: 'lr 12/31/2003 15:49'! pushVariable: aString do: aBlock self push: (RBVariableNode named: aString) do: aBlock ! ! PMStackedVisitor subclass: #PMConditionBuilder instanceVariableNames: 'conditions target ' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Visitor'! !PMConditionBuilder methodsFor: 'utility' stamp: 'lr 12/8/2003 23:06'! addNode: aNode conditions addLast: aNode! ! !PMConditionBuilder methodsFor: 'visiting' stamp: 'lr 12/31/2003 16:47'! visitFunction: aFunction super visitFunction: aFunction. self buildEqualArguments: aFunction. self visit: aFunction condition.! ! !PMConditionBuilder methodsFor: 'accessing' stamp: 'lr 12/8/2003 22:59'! condition ^conditions isEmpty ifTrue: [ RBLiteralNode value: true ] ifFalse: [ conditions fold: [ :receiver :condition | RBMessageNode receiver: receiver selector: #and: arguments: {RBBlockNode body: condition} ] ]! ! !PMConditionBuilder methodsFor: 'utility' stamp: 'lr 12/31/2003 22:46'! visitClassPattern: aPattern (aPattern isReceiver and: [ aPattern parent isPattern not ] and: [ self target includesBehavior: aPattern target ]) ifTrue: [ ^self ]. self addSelector: #isKindOf: argument: aPattern target! ! !PMConditionBuilder methodsFor: 'accessing' stamp: 'lr 12/10/2003 09:54'! target ^target! ! !PMConditionBuilder class methodsFor: 'instance creation' stamp: 'lr 12/10/2003 09:54'! target: aClass visit: aNode ^self new target: aClass; visit: aNode; yourself! ! !PMConditionBuilder methodsFor: 'utility' stamp: 'lr 12/8/2003 23:06'! addSelector: aSymbol self addNode: (RBMessageNode receiver: self top selector: aSymbol)! ! !PMConditionBuilder methodsFor: 'visiting' stamp: 'lr 12/8/2003 22:42'! visitOpenListPattern: aPattern self visitListPattern: aPattern. super visitOpenListPattern: aPattern.! ! !PMConditionBuilder methodsFor: 'accessing' stamp: 'lr 12/10/2003 09:54'! target: aClass target _ aClass! ! !PMConditionBuilder methodsFor: 'visiting' stamp: 'lr 12/8/2003 22:28'! visitExpression: anExpression self addNode: anExpression node! ! !PMConditionBuilder methodsFor: 'visiting' stamp: 'lr 12/10/2003 09:58'! visitListPattern: aPattern self visitClassPattern: aPattern. self pushSelector: #size do: [ self addSelector: (aPattern hasTail ifTrue: [ #>= ] ifFalse: [ #== ]) argument: aPattern size ]. super visitListPattern: aPattern.! ! !PMConditionBuilder methodsFor: 'utility' stamp: 'lr 12/31/2003 16:46'! buildEqualArguments: aFunction aFunction mapping values do: [ :items | items fold: [ :first :second | self addNode: (RBMessageNode receiver: first selector: #= arguments: {second}). second ] ]! ! !PMConditionBuilder methodsFor: 'visiting' stamp: 'lr 12/8/2003 22:33'! visitObjectPattern: aPattern self addSelector: (aPattern isLiteral ifTrue: [ #== ] ifFalse: [ #= ]) argument: aPattern object! ! !PMConditionBuilder methodsFor: 'visiting' stamp: 'lr 12/8/2003 22:24'! visitBlockPattern: aPattern self visit: aPattern expression! ! !PMConditionBuilder methodsFor: 'utility' stamp: 'lr 12/8/2003 23:07'! addSelector: aSymbol argument: aValue self addNode: (RBMessageNode receiver: self top selector: aSymbol arguments: {RBLiteralNode value: aValue})! ! !PMConditionBuilder methodsFor: 'initialization' stamp: 'lr 12/4/2003 22:50'! initialize super initialize. conditions _ OrderedCollection new.! ! !PMStackedVisitor methodsFor: 'utility' stamp: 'lr 12/8/2003 20:19'! push: anObject do: aBlock stack addLast: anObject. aBlock ensure: [ stack removeLast ].! ! !PMStackedVisitor methodsFor: 'private' stamp: 'lr 12/8/2003 22:14'! pushSelector: aSymbol do: aBlock self push: (RBMessageNode receiver: self top selector: aSymbol) do: aBlock ! ! !PMStackedVisitor methodsFor: 'visiting' stamp: 'lr 12/8/2003 22:36'! visitOpenListPattern: aPattern self pushSelector: #allButFirst: argument: aPattern size do: [ self visit: aPattern tail ]! ! !PMVisitor methodsFor: 'utility' stamp: 'lr 12/1/2003 23:12'! visit: anObject anObject acceptVisitor: self.! ! !PMVisitor methodsFor: 'visiting' stamp: 'lr 12/2/2003 09:05'! visitObjectPattern: aPattern self visitPattern: aPattern.! ! !PMVisitor methodsFor: 'visiting' stamp: 'lr 12/3/2003 21:59'! visitFunction: aFunction self visit: aFunction receiver. self visitAll: aFunction arguments. self visit: aFunction condition. self visit: aFunction body.! ! !PMVisitor methodsFor: 'visiting' stamp: 'lr 12/2/2003 09:13'! visitMatchedSelector: aSelector self visitSelector: aSelector. self visit: aSelector pattern.! ! !SequenceableCollection methodsFor: '*Pattern-Examples-Functional' stamp: 'lr 1/2/2004 10:44'! tail "{x|xs}>>tail ""#(1 2 3 4) tail"" ^xs" self size >= 1 ifTrue: [^self allButFirst: 1]. ^self doesNotUnderstand: (Message selector: #tail arguments: { })! ! !SequenceableCollection methodsFor: '*Pattern-Examples-Functional' stamp: 'lr 1/2/2004 10:44'! head "{x|xs}>>head ""#(1 2 3 4) head"" ^x" self size >= 1 ifTrue: [^self at: 1]. ^self doesNotUnderstand: (Message selector: #head arguments: { })! ! !SequenceableCollection methodsFor: '*Pattern-Examples-Functional' stamp: 'lr 1/2/2004 10:44'! map: t1 "{}>>map: aBlockContext ""(1 to: 10) map: [ :x | x fib ]"" ^{}" "{x|xs}>>map: aBlockContext ^{aBlockContext value: x} , (xs map: aBlockContext)" (self size == 0 and: [(t1 isKindOf: BlockContext)]) ifTrue: [^{ }]. (self size >= 1 and: [(t1 isKindOf: BlockContext)]) ifTrue: [^{ t1 value: (self at: 1)} , ((self allButFirst: 1) map: t1)]. ^self doesNotUnderstand: (Message selector: #map: arguments: { t1})! ! !SequenceableCollection methodsFor: '*pattern' stamp: 'lr 12/4/2003 22:50'! fold: aBlock "Evaluate the block with the 1st and the 2nd element of the receiver, then with the result of the first evaluation and the 3rd element, then with the result of the second evaluation and the 4th element... Answer the result of the final evaluation. If the receiver is empty, fail. If the receiver contains a single element, answer the element." " #('to' 'be' 'or' 'not' 'to' 'be') fold: [:a :b | a, ' ', b] " | nextValue | self emptyCheck. nextValue _ self first. 2 to: self size do: [ :index | nextValue _ aBlock value: nextValue value: (self at: index) ]. ^nextValue! ! !SequenceableCollection methodsFor: '*Pattern-Examples-Functional' stamp: 'lr 1/2/2004 10:44'! len "{}>>len ""#(1 2 3 4) len"" ^0" "{x|xs}>>len ^1 + xs len" self size == 0 ifTrue: [^0]. self size >= 1 ifTrue: [^1 + (self allButFirst: 1) len]. ^self doesNotUnderstand: (Message selector: #len arguments: { })! ! !SequenceableCollection methodsFor: '*Pattern-Examples-Functional' stamp: 'lr 1/2/2004 10:44'! zip: t1 "aSequenceableCollection>>zip: {} ""#(1 2 3 4) zip: #(a b c d)"" ^{}" "{}>>zip: aSequenceableCollection ^{}" "{x|xs}>>zip: {y|ys} ^{x. y} , (xs zip: ys)" ((t1 isKindOf: SequenceableCollection) and: [(t1 size == 0)]) ifTrue: [^{ }]. (self size == 0 and: [(t1 isKindOf: SequenceableCollection)]) ifTrue: [^{ }]. ((self size >= 1 and: [(t1 isKindOf: SequenceableCollection)]) and: [(t1 size >= 1)]) ifTrue: [^{ self at: 1. t1 at: 1} , ((self allButFirst: 1) zip: (t1 allButFirst: 1))]. ^self doesNotUnderstand: (Message selector: #zip: arguments: { t1})! ! MCTool subclass: #PMBrowser instanceVariableNames: 'categories categorySelection functionSelection textMorph source sourceSelection ' classVariableNames: '' poolDictionaries: '' category: 'Pattern-UI'! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 12/4/2003 13:08'! categoryList ^categories collect: [ :each | each name ]! ! !PMBrowser methodsFor: 'testing' stamp: 'lr 12/4/2003 14:07'! hasChanges self changed: #wantToChange. ^self canDiscardEdits not ! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 12/10/2003 10:31'! categorySelection: aNumber self hasChanges ifFalse: [ categorySelection _ aNumber. self changed: #categorySelection. self changed: #functionList. self functionSelection: 0. aNumber isZero ifTrue: [ self source: String new ] ]! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 12/6/2003 14:48'! buttonSpecs ^#( ('Refresh' refresh 'Refresh the view') ('Browse' browse 'Browse the selected function' hasSelectedCategory) ('Move Up' moveUpFunction 'Move the selected function upwards' hasSelectedFunction) ('Move Down' moveDownFunction 'Move the selected function downwards' hasSelectedFunction) )! ! !PMBrowser methodsFor: 'testing' stamp: 'lr 12/4/2003 11:21'! hasSelectedFunction ^self functionSelection isZero not! ! !PMBrowser methodsFor: 'actions' stamp: 'lr 12/10/2003 10:35'! removeCategory self hasSelectedCategory ifTrue: [ (PopUpMenu confirm: 'Are you sure you want to remove this category and all its functions?') ifTrue: [ self category removeAll. self refresh ] ]! ! !PMBrowser methodsFor: 'actions' stamp: 'lr 12/4/2003 17:44'! refresh categories _ PMCategory allCategories asSortedCollection: [ :x :y | x name < y name ]. self categorySelection: 0. self changed: #categoryList; changed: #functionList; changed: #sourceText.! ! !PMBrowser methodsFor: 'actions' stamp: 'lr 12/31/2003 23:46'! removeFunction self hasSelectedFunction ifTrue: [ self category remove: self function. self changed: #functionList. self addFunction ]! ! !PMBrowser methodsFor: 'actions' stamp: 'lr 12/11/2003 07:12'! moveDownFunction (self hasSelectedFunction and: [ functionSelection < self category functions size ]) ifTrue: [ self category moveDown: self function. self functionSelection: functionSelection + 1. self changed: #functionList ]! ! !PMBrowser methodsFor: 'testing' stamp: 'lr 12/4/2003 11:21'! hasSelectedCategory ^self categorySelection isZero not! ! !PMBrowser methodsFor: 'actions' stamp: 'lr 12/31/2003 23:47'! addFunction functionSelection _ 0. self source: PMFunction template asText. self selection: (1 to: source size). self changed: #functionSelection. self changed: #sourceString. ! ! !PMBrowser methodsFor: 'utility' stamp: 'lr 12/4/2003 15:02'! source: aString source _ aString. self changed: #sourceString.! ! !PMBrowser methodsFor: 'actions' stamp: 'lr 12/4/2003 14:47'! clearUserEditFlag self changed: #clearUserEdits.! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 12/4/2003 09:16'! defaultExtent ^650@400! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 12/4/2003 13:58'! sourceString ^source! ! !PMBrowser methodsFor: 'actions' stamp: 'lr 12/10/2003 09:47'! browse | selectedIndex messages messageSet | selectedIndex _ 0. messages _ self category groups collectWithIndex: [ :group :index | self hasSelectedFunction ifTrue: [ self function selector = group first selector ifTrue: [ selectedIndex _ index ] ]. String streamContents: [ :stream | stream nextPutAll: (self category targetFor: group) name. stream nextPutAll: ' '. stream nextPutAll: group first selector ] ]. messageSet _ MessageSet messageList: messages. messageSet messageListIndex: selectedIndex. MessageSet open: messageSet name: 'Functions in ' , self category name! ! !PMBrowser methodsFor: 'accessing' stamp: 'lr 12/4/2003 13:29'! category ^(categorySelection between: 1 and: categories size) ifTrue: [ categories at: categorySelection ] ifFalse: [ nil ]! ! !PMBrowser methodsFor: 'utility' stamp: 'lr 12/4/2003 15:18'! parseError: aString at: aNumber | errorString | errorString _ String streamContents: [ :stream | stream nextPutAll: (aString copyFrom: 19 to: aString size). stream nextPutAll: ' ->' ]. textMorph selectFrom: aNumber to: aNumber - 1. textMorph replaceSelectionWith: errorString.! ! !PMBrowser methodsFor: 'initialization' stamp: 'lr 12/4/2003 14:20'! initialize categories _ OrderedCollection new. categorySelection _ functionSelection _ 0. source _ String new. sourceSelection _ 1 to: 0.! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 12/4/2003 13:28'! categorySelection ^categorySelection! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 12/4/2003 15:12'! textMorph: aSelector ^textMorph _ PluggableTextMorph on: self text: (aSelector , 'String') asSymbol accept: (aSelector , 'String:') asSymbol readSelection: (aSelector , 'Selection') asSymbol menu: (aSelector , 'Menu:shifted:') asSymbol ! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 12/10/2003 10:30'! functionSelection: aNumber self hasChanges ifFalse: [ aNumber isZero ifTrue: [ self addFunction. self selection: (1 to: source size) ] ifFalse: [ self source: (self category functions at: aNumber) asText. self selection: (1 to: 0) ]. functionSelection _ aNumber. self changed: #functionSelection ]! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 12/4/2003 11:23'! functionListMenu: aMenu ^aMenu add: 'add' target: self selector: #addFunction; add: 'remove' target: self selector: #removeFunction; addLine; add: 'move up' target: self selector: #moveUpFunction; add: 'move down' target: self selector: #moveDownFunction; yourself! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 12/4/2003 15:41'! functionList ^self hasSelectedCategory ifTrue: [ self category functions collect: [ :each | each printString ] ] ifFalse: [ Array new ]! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 12/4/2003 09:15'! defaultLabel ^'Function Browser'! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 12/4/2003 13:45'! functionSelection ^functionSelection! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 12/9/2003 20:42'! windowColor ^Color blue mixed: 0.5 with: Color white! ! !PMBrowser methodsFor: 'actions' stamp: 'lr 12/10/2003 10:37'! addCategory | result index | result _ FillInTheBlank request: 'Please type new category name' initialAnswer: 'Category-Name'. result isNil ifFalse: [ index _ categories findFirst: [ :each | result = each name ]. index isZero ifTrue: [ index _ categories indexOf: (categories add: (PMCategory name: result)) ]. self changed: #categoryList. self categorySelection: index ].! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 12/4/2003 13:59'! sourceSelection ^sourceSelection! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 12/9/2003 20:38'! buildWindow ^super buildWindow paneColor: self windowColor; yourself! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 12/10/2003 10:45'! sourceString: aString | function | self hasSelectedCategory ifTrue: [ function _ PMParser parse: aString onError: [ :string :position | ^self parseError: string at: position ]. function isNil ifFalse: [ (self category add: function) ifTrue: [ self changed: #functionList ]. self source: aString ]. self functionSelection: (self category functions indexOf: function) ]! ! !PMBrowser methodsFor: 'utility' stamp: 'lr 12/4/2003 15:02'! selection: aSelection sourceSelection _ aSelection. self changed: #sourceSelection.! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 12/4/2003 12:09'! sourceMenu: aMenu shifted: aBoolean ^StringHolder new codePaneMenu: aMenu shifted: aBoolean! ! !PMBrowser methodsFor: 'accessing' stamp: 'lr 12/4/2003 16:11'! function ^self hasSelectedFunction ifTrue: [ self category functions at: functionSelection ] ifFalse: [ nil ]! ! !PMBrowser methodsFor: 'actions' stamp: 'lr 12/10/2003 10:36'! renameCategory | result | self hasSelectedCategory ifTrue: [ result _ FillInTheBlank request: 'Please type new category name' initialAnswer: self category name. result isNil ifFalse: [ categories detect: [ :each | result = each name ] ifNone: [ self category renameTo: result. self refresh. self categorySelection: (self categoryList indexOf: result) ] ] ]! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 12/4/2003 14:42'! categoryListMenu: aMenu ^aMenu add: 'add...' target: self selector: #addCategory; add: 'rename...' target: self selector: #renameCategory; add: 'remove' target: self selector: #removeCategory; addLine; add: 'refresh' target: self selector: #refresh; yourself! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 12/4/2003 11:58'! widgetSpecs ^#( ((listMorph: category) (0 0 0.25 0.4) (0 0 0 -30)) ((listMorph: function) (0.25 0 1 0.4) (0 0 0 -30)) ((buttonRow) (0 0.4 1 0.4) (0 -30 0 0)) ((textMorph: source) (0 0.4 1 1)) )! ! !PMBrowser methodsFor: 'actions' stamp: 'lr 12/11/2003 07:12'! moveUpFunction (self hasSelectedFunction and: [ functionSelection > 1 ]) ifTrue: [ self category moveUp: self function. self functionSelection: functionSelection - 1. self changed: #functionList ]! ! !PMBrowser class methodsFor: 'instance creation' stamp: 'lr 12/9/2003 20:01'! open "self open" self new initialize; show; refresh! ! TestCase subclass: #PMFunctionalTest instanceVariableNames: 'function ' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Tests'! PMFunctionalTest subclass: #PMVisitorTest instanceVariableNames: 'mapping ' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Tests'! !PMVisitorTest methodsFor: 'testing-arguments' stamp: 'lr 12/31/2003 15:41'! testMultipleArgument self mappingOf: 'a>>foo: b bar: c'. self assert: mapping size = 3. self assert: (mapping at: 'a') = 'self'. self assert: (mapping at: 'b') = 't1'. self assert: (mapping at: 'c') = 't2'. self mappingOf: '{a.b.c}>>foo: {d.e.f} bar: {g|i}'. self assert: mapping size = 8. self assert: (mapping at: 'a') = 'self at: 1'. self assert: (mapping at: 'b') = 'self at: 2'. self assert: (mapping at: 'c') = 'self at: 3'. self assert: (mapping at: 'd') = 't1 at: 1'. self assert: (mapping at: 'e') = 't1 at: 2'. self assert: (mapping at: 'f') = 't1 at: 3'. self assert: (mapping at: 'g') = 't2 at: 1'. self assert: (mapping at: 'i') = 't2 allButFirst: 1'. self mappingOf: 'a>>foo: {b | [ :c | c size > 3 ]} bar: 0 zork: d'. self assert: mapping size = 4. self assert: (mapping at: 'a') = 'self'. self assert: (mapping at: 'b') = 't1 at: 1'. self assert: (mapping at: 'c') = 't1 allButFirst: 1'. self assert: (mapping at: 'd') = 't3'.! ! !PMVisitorTest methodsFor: 'testing-arguments' stamp: 'lr 12/8/2003 21:59'! testObjectArgument self mappingOf: '0>>foo: true'. self assert: mapping size = 0. self mappingOf: '0>>foo: 123'. self assert: mapping size = 0. self mappingOf: '0>>foo: a'. self assert: mapping size = 1. self assert: (mapping at: 'a') = 't1'. self mappingOf: '0>>foo: [ :a | a isFoo ]'. self assert: mapping size = 1. self assert: (mapping at: 'a') = 't1'. self mappingOf: '0>>foo: anAssociation'. self assert: mapping size = 1. self assert: (mapping at: 'anAssociation') = 't1'.! ! !PMVisitorTest methodsFor: 'testing-arguments' stamp: 'lr 12/8/2003 21:55'! testOpenListArgument self mappingOf: '0>>foo: {x|xs}'. self assert: mapping size = 2. self assert: (mapping at: 'x') = 't1 at: 1'. self assert: (mapping at: 'xs') = 't1 allButFirst: 1'. self mappingOf: '0>>foo: {x. y|xs}'. self assert: mapping size = 3. self assert: (mapping at: 'x') = 't1 at: 1'. self assert: (mapping at: 'y') = 't1 at: 2'. self assert: (mapping at: 'xs') = 't1 allButFirst: 2'. self mappingOf: '0>>foo: {x. y. z|xs}'. self assert: mapping size = 4. self assert: (mapping at: 'x') = 't1 at: 1'. self assert: (mapping at: 'y') = 't1 at: 2'. self assert: (mapping at: 'z') = 't1 at: 3'. self assert: (mapping at: 'xs') = 't1 allButFirst: 3'. self mappingOf: '0>>foo: {x|nil}'. self assert: mapping size = 1. self assert: (mapping at: 'x') = 't1 at: 1'.! ! !PMVisitorTest methodsFor: 'testing-arguments' stamp: 'lr 12/31/2003 15:39'! testListArgument self mappingOf: '0>>foo: {}'. self assert: mapping size = 0. self mappingOf: '0>>foo: {x}'. self assert: mapping size = 1. self assert: (mapping at: 'x') = 't1 at: 1'. self mappingOf: '0>>foo: {x.y}'. self assert: mapping size = 2. self assert: (mapping at: 'x') = 't1 at: 1'. self assert: (mapping at: 'y') = 't1 at: 2'. self mappingOf: '0>>foo: {x.y.z}'. self assert: mapping size = 3. self assert: (mapping at: 'x') = 't1 at: 1'. self assert: (mapping at: 'y') = 't1 at: 2'. self assert: (mapping at: 'z') = 't1 at: 3'. self mappingOf: '0>>foo: {true. y. false}'. self assert: mapping size = 1. self assert: (mapping at: 'y') = 't1 at: 2'. ! ! !PMVisitorTest methodsFor: 'testing-printing' stamp: 'lr 12/4/2003 10:10'! testConditionPrinting self assertFunction: 'a>>foo if: [ self foo ]'. self assertFunction: 'a>>foo if: [ self foo ]'.! ! !PMVisitorTest methodsFor: 'testing-arguments' stamp: 'lr 12/31/2003 15:38'! testNestedListArgument self mappingOf: '0>>foo: {x|{}}'. self assert: mapping size = 1. self assert: (mapping at: 'x') = 't1 at: 1'. self mappingOf: '0>>foo: {x|{y}}'. self assert: mapping size = 2. self assert: (mapping at: 'x') = 't1 at: 1'. self assert: (mapping at: 'y') = '(t1 allButFirst: 1) at: 1'. self mappingOf: '0>>foo: {x|{y|ys}}'. self assert: mapping size = 3. self assert: (mapping at: 'x') = 't1 at: 1'. self assert: (mapping at: 'y') = '(t1 allButFirst: 1) at: 1'. self assert: (mapping at: 'ys') = '(t1 allButFirst: 1) allButFirst: 1'. ! ! !PMVisitorTest methodsFor: 'testing-arguments' stamp: 'lr 12/8/2003 22:00'! testReceiverArgument self mappingOf: 'a>>foo'. self assert: mapping size = 1. self assert: (mapping at: 'a') = 'self'. self mappingOf: '[ :a | a isFoo ]>>foo'. self assert: mapping size = 1. self assert: (mapping at: 'a') = 'self'. self mappingOf: 'anAssociation>>foo'. self assert: mapping size = 1. self assert: (mapping at: 'anAssociation') = 'self'. self mappingOf: '{x|xs}>>foo'. self assert: mapping size = 2. self assert: (mapping at: 'x') = 'self at: 1'. self assert: (mapping at: 'xs') = 'self allButFirst: 1'. ! ! !PMVisitorTest methodsFor: 'utility' stamp: 'lr 12/2/2003 12:40'! assertSignature: aString self assert: (self parse: aString) asString = aString! ! !PMVisitorTest methodsFor: 'testing-printing' stamp: 'lr 1/2/2004 10:40'! testSignaturePrinting self assertSignature: 'a>>foo: true'. self assertSignature: 'a>>foo: false'. self assertSignature: 'a>>foo: nil'. self assertSignature: 'a>>+ b'. self assertSignature: 'a>>== b'. self assertSignature: 'a>>// b'. self assertSignature: 'a>>foo: aPoint'. self assertSignature: 'a>>foo: anInteger'. self assertSignature: 'a>>foo: b'. self assertSignature: 'a>>foo: b bar: c'. self assertSignature: 'a>>foo: b bar: c zork: d'. self assertSignature: 'a>>foo: {}'. self assertSignature: 'a>>foo: {x}'. self assertSignature: 'a>>foo: {x. y}'. self assertSignature: 'a>>foo: {x. y. z}'. self assertSignature: 'a>>foo: {x|xs}'. self assertSignature: 'a>>foo: {x. y|ys}'. self assertSignature: 'a>>foo: {x. y. z|zs}'. self assertSignature: 'a>>foo: {x|{y}}'. self assertSignature: 'a>>foo: {x|{y|ya}}'. self assertSignature: 'a>>foo: {x|{y|{z|zs}}}'. self assertSignature: 'a>>foo: {1|x}'. self assertSignature: 'a>>foo: {1. 2|x}'. self assertSignature: 'a>>foo: {#a.|x}'. self assertSignature: 'a>>foo: {#a. #b.|x}'. self assertSignature: 'a>>foo: 123'. self assertSignature: 'a>>foo: 123.456'. self assertSignature: 'a>>foo: $a'. self assertSignature: 'a>>foo: ''abc'''. self assertSignature: 'a>>foo: #abc:abc:'. self assertSignature: 'a>>foo'. self assertSignature: '0>>foo'. self assertSignature: '{}>>foo'. self assertSignature: 'a>>foo: #''a b c'''. self assertSignature: 'a>>foo: #abc'. self assertSignature: 'a>>foo: #+'. self assertSignature: 'a>>foo: #abc:'. self assertSignature: 'a>>foo: #abc:abc:'. self assertSignature: 'a>>foo: [ :b | b ]'. self assertSignature: 'a>>foo: [ :b | b < 0 ]'. self assertSignature: 'a>>foo: [ :b | b asInteger < 0 ]'.! ! !PMVisitorTest methodsFor: 'utility' stamp: 'lr 12/4/2003 10:11'! assertFunction: aString | output | output _ String streamContents: [ :stream | PMFunctionPrinter print: (self parse: aString) on: stream ]. self assert: aString = output.! ! !PMVisitorTest methodsFor: 'testing-arguments' stamp: 'lr 12/31/2003 15:58'! testEqualArgument self mappingOf: 'x>>foo: x'. self assert: mapping size = 1. self assert: (mapping at: 'x') = #( 'self' 't1' ). self mappingOf: 'x>>foo: x bar: x'. self assert: mapping size = 1. self assert: (mapping at: 'x') = #( 'self' 't1' 't2' ). self mappingOf: 'x>>foo: x bar: y zork: y'. self assert: mapping size = 2. self assert: (mapping at: 'x') = #( 'self' 't1' ). self assert: (mapping at: 'y') = #( 't2' 't3' ). self mappingOf: 'aSymbol>>foo: aSymbol'. self assert: mapping size = 1. self assert: (mapping at: 'aSymbol') = #( 'self' 't1' ). self mappingOf: '[ :x | x ]>>foo: [ :x | x not ]'. self assert: mapping size = 1. self assert: (mapping at: 'x') = #( 'self' 't1' ). self mappingOf: '{x}>>foo: {x.x}'. self assert: mapping size = 1. self assert: (mapping at: 'x') = #( 'self at: 1' 't1 at: 1' 't1 at: 2' ). self mappingOf: '{x|xs}>>foo: {x|xs}'. self assert: mapping size = 2. self assert: (mapping at: 'x') = #( 'self at: 1' 't1 at: 1' ). self assert: (mapping at: 'xs') = #( 'self allButFirst: 1' 't1 allButFirst: 1' ). ! ! !PMVisitorTest methodsFor: 'utility' stamp: 'lr 12/31/2003 15:40'! mappingOf: aString mapping _ Dictionary new. function _ self parse: aString. (PMArgumentMapper visit: function) mapping keysAndValuesDo: [ :key :value | mapping at: key formattedCode put: (value size = 1 ifTrue: [ value first formattedCode ] ifFalse: [ (value collect: [ :each | each formattedCode ]) asArray ]) ]! ! !PMVisitorTest methodsFor: 'testing-printing' stamp: 'lr 12/4/2003 21:37'! testBodyPrinting self assertFunction: 'a>>foo ^self foo'. self assertFunction: 'a>>foo ^self foo'.! ! PMFunctionalTest subclass: #PMParserTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Tests'! !PMParserTest methodsFor: 'testing' stamp: 'lr 12/3/2003 21:22'! testBodyError self should: [ self parse: 'a>>b ^' ] raise: SmaCCParserError. self should: [ self parse: 'a>>b [' ] raise: SmaCCParserError. self should: [ self parse: 'a>>b ]' ] raise: SmaCCParserError. self should: [ self parse: 'a>>b * 1' ] raise: SmaCCParserError. ! ! !PMParserTest methodsFor: 'testing' stamp: 'lr 12/8/2003 20:32'! testBlockPatternError self should: [ self parse: 'anInteger>>foo: [' ] raise: SmaCCParserError. self should: [ self parse: 'anInteger>>foo: []' ] raise: SmaCCParserError. self should: [ self parse: 'anInteger>>foo: [:|' ] raise: SmaCCParserError. self should: [ self parse: 'anInteger>>foo: [:a|' ] raise: SmaCCParserError. self should: [ self parse: 'anInteger>>foo: [:a|a+' ] raise: SmaCCParserError.! ! !PMParserTest methodsFor: 'testing-selector' stamp: 'lr 12/8/2003 21:19'! testSelector function _ self parse: 'a>>foo'. self assert: function arguments first class == PMSelector. self assert: function arguments first parent == function. self assert: function arguments first selector = #foo. function _ self parse: 'a>>foo: b'. self assert: function arguments first class == PMMatchedSelector. self assert: function arguments first parent == function. self assert: function arguments first selector = #foo:. self assert: function arguments first pattern class == PMVariablePattern. self assert: function arguments first pattern parent == function arguments first. self assert: function arguments first pattern name = 'b'.! ! !PMParserTest methodsFor: 'testing-pattern' stamp: 'lr 12/31/2003 20:01'! testBlock function _ self parse: 'a>>foo: [ :b | b ]'. self assert: function arguments first pattern class == PMBlockPattern. self assert: function arguments first pattern parent == function arguments first. self assert: function arguments first pattern name = 'b'. self assert: function arguments first pattern expression class == PMExpression. self assert: function arguments first pattern expression parent == function arguments first pattern. self assert: function arguments first pattern expression source = ' b '. self assert: function arguments first pattern expression node class == RBVariableNode. self assert: function arguments first pattern expression node name = 't1'.! ! !PMParserTest methodsFor: 'testing-pattern' stamp: 'lr 12/8/2003 21:16'! testVariable function _ self parse: 'a>>foo: b'. self assert: function arguments first class == PMMatchedSelector. self assert: function arguments first parent == function. self assert: function arguments first selector = #foo:. self assert: function arguments first pattern class == PMVariablePattern. self assert: function arguments first pattern parent == function arguments first. self assert: function arguments first pattern name = 'b'.! ! !PMParserTest methodsFor: 'testing-code' stamp: 'lr 12/31/2003 20:00'! testBody function _ self parse: 'a>>foo a'. self assert: function body class == PMExpression. self assert: function body source = ' a'. self assert: function body node class == RBVariableNode. self assert: function body node name = 'self'. self assert: function body parent == function. function _ self parse: 'a>>+ b a'. self assert: function body class == PMExpression. self assert: function body source = ' a'. self assert: function body node class == RBVariableNode. self assert: function body node name = 'self'. self assert: function body parent == function. function _ self parse: 'a>>foo: b a'. self assert: function body class == PMExpression. self assert: function body source = ' a'. self assert: function body node class == RBVariableNode. self assert: function body node name = 'self'. self assert: function body parent == function.! ! !PMParserTest methodsFor: 'testing' stamp: 'lr 12/8/2003 21:08'! testWhitespace function _ self parse: 'a>>foo: b if: [a]b'. self assert: function receiver class == PMVariablePattern. self assert: function receiver name = 'a'. self assert: function selector = #foo:. self assert: function arguments first class == PMMatchedSelector. self assert: function arguments first selector = #foo:. self assert: function arguments first pattern class == PMVariablePattern. self assert: function arguments first pattern name = 'b'. self assert: function condition class == PMExpression. self assert: function condition source = 'a'. self assert: function body class == PMExpression. self assert: function body source = 'b'. function _ self parse: 'a >> foo: b if: [ a ] b'. self assert: function receiver class == PMVariablePattern. self assert: function receiver name = 'a'. self assert: function selector = #foo:. self assert: function arguments first class == PMMatchedSelector. self assert: function arguments first selector = #foo:. self assert: function arguments first pattern class == PMVariablePattern. self assert: function arguments first pattern name = 'b'. self assert: function condition class == PMExpression. self assert: function condition source = ' a '. self assert: function body class == PMExpression. self assert: function body source = ' b'. function _ self parse: 'a>> foo: b if: [ a ] b '. self assert: function receiver class == PMVariablePattern. self assert: function receiver name = 'a'. self assert: function selector = #foo:. self assert: function arguments first class == PMMatchedSelector. self assert: function arguments first selector = #foo:. self assert: function arguments first pattern class == PMVariablePattern. self assert: function arguments first pattern name = 'b'. self assert: function condition class == PMExpression. self assert: function condition source = ' a '. self assert: function body class == PMExpression. self assert: function body source = ' b '. ! ! !PMParserTest methodsFor: 'testing' stamp: 'lr 12/3/2003 21:31'! testConditionError self should: [ self parse: 'a>>b if: [' ] raise: SmaCCParserError. self should: [ self parse: 'a>>b if: [[' ] raise: SmaCCParserError. self should: [ self parse: 'a>>b if: []]' ] raise: SmaCCParserError. self should: [ self parse: 'a>>b if: [1+' ] raise: SmaCCParserError.! ! !PMParserTest methodsFor: 'testing-selector' stamp: 'lr 12/2/2003 12:39'! testBinarySelector function _ self parse: 'a>>+ b'. self assert: function selector = #+. self assert: function arguments size = 1. function _ self parse: 'a>>== b'. self assert: function selector = #==. self assert: function arguments size = 1. function _ self parse: 'a>>// b'. self assert: function selector = #//. self assert: function arguments size = 1. ! ! !PMParserTest methodsFor: 'testing-pattern' stamp: 'lr 12/8/2003 21:15'! testOpenList function _ self parse: 'a>>foo: {x|xs}'. self assert: function arguments first pattern class == PMOpenListPattern. self assert: function arguments first pattern parent == function arguments first. self assert: function arguments first pattern size = 1. self deny: function arguments first pattern isEmpty. self assert: function arguments first pattern items first class == PMVariablePattern. self assert: function arguments first pattern items first parent == function arguments first pattern. self assert: function arguments first pattern items first name = 'x'. self assert: function arguments first pattern tail class == PMVariablePattern. self assert: function arguments first pattern tail parent == function arguments first pattern. self assert: function arguments first pattern tail name = 'xs'. function _ self parse: 'a>>foo: {x|{y}}'. self assert: function arguments first pattern class == PMOpenListPattern. self assert: function arguments first pattern parent == function arguments first. self assert: function arguments first pattern size = 1. self deny: function arguments first pattern isEmpty. self assert: function arguments first pattern items first class == PMVariablePattern. self assert: function arguments first pattern items first parent == function arguments first pattern. self assert: function arguments first pattern items first name = 'x'. self assert: function arguments first pattern tail class == PMListPattern. self assert: function arguments first pattern tail parent == function arguments first pattern. self assert: function arguments first pattern tail items size = 1. self assert: function arguments first pattern tail items first class == PMVariablePattern. self assert: function arguments first pattern tail items first parent == function arguments first pattern tail. self assert: function arguments first pattern tail items first name = 'y'.! ! !PMParserTest methodsFor: 'testing-code' stamp: 'lr 12/8/2003 21:09'! testBoth function _ self parse: 'a>>foo if: [ a ] b'. self assert: function condition class == PMExpression. self assert: function condition source = ' a '. self assert: function condition parent == function. self assert: function body class == PMExpression. self assert: function body source = ' b'. self assert: function body parent == function. function _ self parse: 'a>>+ b if: [ a ] b'. self assert: function condition class == PMExpression. self assert: function condition source = ' a '. self assert: function condition parent == function. self assert: function body class == PMExpression. self assert: function body source = ' b'. self assert: function body parent == function. function _ self parse: 'a>>foo: b if: [ a ] b'. self assert: function condition class == PMExpression. self assert: function condition source = ' a '. self assert: function condition parent == function. self assert: function body class == PMExpression. self assert: function body source = ' b'. self assert: function body parent == function. ! ! !PMParserTest methodsFor: 'testing-code' stamp: 'lr 12/31/2003 20:00'! testCondition function _ self parse: 'a>>foo if: [ a ]'. self assert: function condition class == PMExpression. self assert: function condition source = ' a '. self assert: function condition node class == RBVariableNode. self assert: function condition node name = 'self'. self assert: function condition parent == function. function _ self parse: 'a>>+ b if: [ a ]'. self assert: function condition class == PMExpression. self assert: function condition source = ' a '. self assert: function condition node class == RBVariableNode. self assert: function condition node name = 'self'. self assert: function condition parent == function. function _ self parse: 'a>>foo: b if: [ a ]'. self assert: function condition class == PMExpression. self assert: function condition source = ' a '. self assert: function condition node class == RBVariableNode. self assert: function condition node name = 'self'. self assert: function condition parent == function.! ! !PMParserTest methodsFor: 'testing-selector' stamp: 'lr 12/2/2003 12:40'! testUnarySelector function _ self parse: 'a>>foo'. self assert: function selector = #foo. self assert: function arguments size = 1.! ! !PMParserTest methodsFor: 'testing' stamp: 'lr 12/8/2003 20:33'! testListPatternError self should: [ self parse: 'anInteger>>foo: {' ] raise: SmaCCParserError. self should: [ self parse: 'anInteger>>foo: {a' ] raise: SmaCCParserError. self should: [ self parse: 'anInteger>>foo: {a|' ] raise: SmaCCParserError. self should: [ self parse: 'anInteger>>foo: {a|b' ] raise: SmaCCParserError. self should: [ self parse: 'anInteger>>foo: {a|b|' ] raise: SmaCCParserError.! ! !PMParserTest methodsFor: 'testing-pattern' stamp: 'lr 12/10/2003 09:51'! testObject function _ self parse: 'a>>foo: ''abc'''. self assert: function arguments first pattern class == PMObjectPattern. self assert: function arguments first pattern parent == function arguments first. self assert: function arguments first pattern target == String. self assert: function arguments first pattern object = 'abc'. self deny: function arguments first pattern isLiteral.! ! !PMParserTest methodsFor: 'testing-pattern' stamp: 'lr 12/8/2003 21:10'! testClass function _ self parse: 'a>>foo: aPoint'. self assert: function arguments first pattern class == PMClassPattern. self assert: function arguments first pattern parent == function arguments first. self assert: function arguments first pattern name = 'aPoint'. self assert: function arguments first pattern target == Point. function _ self parse: 'a>>foo: anInteger'. self assert: function arguments first pattern class == PMClassPattern. self assert: function arguments first pattern parent == function arguments first. self assert: function arguments first pattern name = 'anInteger'. self assert: function arguments first pattern target == Integer.! ! !PMParserTest methodsFor: 'testing' stamp: 'lr 12/8/2003 20:31'! testPatternBlockError self should: [ self parse: 'anInteger>>foo: [' ] raise: SmaCCParserError. self should: [ self parse: 'anInteger>>foo: []' ] raise: SmaCCParserError. self should: [ self parse: 'anInteger>>foo: [:|' ] raise: SmaCCParserError. self should: [ self parse: 'anInteger>>foo: [:a|' ] raise: SmaCCParserError. self should: [ self parse: 'anInteger>>foo: [:a|a+' ] raise: SmaCCParserError.! ! !PMParserTest methodsFor: 'testing-pattern' stamp: 'lr 12/8/2003 21:16'! testReceiver function _ self parse: 'a>>foo'. self assert: function receiver class == PMVariablePattern. self assert: function receiver parent == function. self assert: function receiver name = 'a'. function _ self parse: '0>>foo'. self assert: function receiver class == PMObjectPattern. self assert: function receiver parent == function. self assert: function receiver object = 0. function _ self parse: '{}>>foo'. self assert: function receiver class == PMListPattern. self assert: function receiver parent == function. self assert: function receiver isEmpty.! ! !PMParserTest methodsFor: 'testing-selector' stamp: 'lr 12/2/2003 12:39'! testKeywordSelector function _ self parse: 'a>>foo: b'. self assert: function selector = #foo:. self assert: function arguments size = 1. function _ self parse: 'a>>foo: b bar: c'. self assert: function selector = #foo:bar:. self assert: function arguments size = 2. function _ self parse: 'a>>foo: b bar: c zork: d'. self assert: function selector = #foo:bar:zork:. self assert: function arguments size = 3. ! ! !PMParserTest methodsFor: 'testing' stamp: 'lr 12/4/2003 10:33'! testSignatureError self should: [ self parse: '' ] raise: SmaCCParserError. self should: [ self parse: '>>' ] raise: SmaCCParserError. self should: [ self parse: 'anInteger' ] raise: SmaCCParserError. self should: [ self parse: 'anInteger>>' ] raise: SmaCCParserError. self should: [ self parse: 'anInteger>>+' ] raise: SmaCCParserError. self should: [ self parse: 'anInteger>>foo:' ] raise: SmaCCParserError. self should: [ self parse: 'anInteger>>foo: [' ] raise: SmaCCParserError. self should: [ self parse: 'anInteger>>foo: []' ] raise: SmaCCParserError. self should: [ self parse: 'anInteger>>foo: [:|' ] raise: SmaCCParserError. self should: [ self parse: 'anInteger>>foo: [:a|' ] raise: SmaCCParserError. self should: [ self parse: 'anInteger>>foo: [:a|a+' ] raise: SmaCCParserError. ! ! !PMParserTest methodsFor: 'testing-pattern' stamp: 'lr 12/10/2003 09:51'! testLiteral function _ self parse: 'a>>foo: true'. self assert: function arguments first pattern class == PMObjectPattern. self assert: function arguments first pattern parent == function arguments first. self assert: function arguments first pattern target == True. self assert: function arguments first pattern object = true. self assert: function arguments first pattern isLiteral. function _ self parse: 'a>>foo: false'. self assert: function arguments first pattern class == PMObjectPattern. self assert: function arguments first pattern parent == function arguments first. self assert: function arguments first pattern target == False. self assert: function arguments first pattern object = false. self assert: function arguments first pattern isLiteral. function _ self parse: 'a>>foo: nil'. self assert: function arguments first pattern class == PMObjectPattern. self assert: function arguments first pattern parent == function arguments first. self assert: function arguments first pattern target == UndefinedObject. self assert: function arguments first pattern object = nil. self assert: function arguments first pattern isLiteral. function _ self parse: 'a>>foo: 123'. self assert: function arguments first pattern class == PMObjectPattern. self assert: function arguments first pattern parent == function arguments first. self assert: function arguments first pattern target == SmallInteger. self assert: function arguments first pattern object = 123. self assert: function arguments first pattern isLiteral. function _ self parse: 'a>>foo: 1.23'. self assert: function arguments first pattern class == PMObjectPattern. self assert: function arguments first pattern parent == function arguments first. self assert: function arguments first pattern target == Float. self assert: function arguments first pattern object = 1.23. self assert: function arguments first pattern isLiteral. function _ self parse: 'a>>foo: #abc'. self assert: function arguments first pattern class == PMObjectPattern. self assert: function arguments first pattern parent == function arguments first. self assert: function arguments first pattern target == Symbol. self assert: function arguments first pattern object = #abc. self assert: function arguments first pattern isLiteral. function _ self parse: 'a>>foo: #a:b:c:'. self assert: function arguments first pattern class == PMObjectPattern. self assert: function arguments first pattern parent == function arguments first. self assert: function arguments first pattern target == Symbol. self assert: function arguments first pattern object = #a:b:c:. self assert: function arguments first pattern isLiteral. function _ self parse: 'a>>foo: #''abc'''. self assert: function arguments first pattern class == PMObjectPattern. self assert: function arguments first pattern parent == function arguments first. self assert: function arguments first pattern target == Symbol. self assert: function arguments first pattern object = #'abc'. self assert: function arguments first pattern isLiteral. function _ self parse: 'a>>foo: #++'. self assert: function arguments first pattern class == PMObjectPattern. self assert: function arguments first pattern parent == function arguments first. self assert: function arguments first pattern target == Symbol. self assert: function arguments first pattern object = #++. self assert: function arguments first pattern isLiteral.! ! !PMParserTest methodsFor: 'testing-pattern' stamp: 'lr 12/8/2003 21:10'! testList function _ self parse: 'a>>foo: {}'. self assert: function arguments first pattern class == PMListPattern. self assert: function arguments first pattern parent == function arguments first. self assert: function arguments first pattern size = 0. self assert: function arguments first pattern isEmpty. function _ self parse: 'a>>foo: {x}'. self assert: function arguments first pattern class == PMListPattern. self assert: function arguments first pattern parent == function arguments first. self assert: function arguments first pattern size = 1. self deny: function arguments first pattern isEmpty. self assert: function arguments first pattern items first class == PMVariablePattern. self assert: function arguments first pattern items first parent == function arguments first pattern. self assert: function arguments first pattern items first name = 'x'. function _ self parse: 'a>>foo: {x.y}'. self assert: function arguments first pattern class == PMListPattern. self assert: function arguments first pattern parent == function arguments first. self assert: function arguments first pattern size = 2. self deny: function arguments first pattern isEmpty. self assert: function arguments first pattern items first class == PMVariablePattern. self assert: function arguments first pattern items first parent == function arguments first pattern. self assert: function arguments first pattern items first name = 'x'. self assert: function arguments first pattern items second class == PMVariablePattern. self assert: function arguments first pattern items second parent == function arguments first pattern. self assert: function arguments first pattern items second name = 'y'. ! ! PMFunctionalTest subclass: #PMBuildTest instanceVariableNames: 'category mock ' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Tests'! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 17:34'! testEqualList2 category add: (self parse: 'aPMMock>>foo: {a.b} bar: {c.b} ^true'). category add: (self parse: 'aPMMock>>foo: {a.b} bar: {c.d} ^false'). self deny: (mock foo: #(a b) bar: #(a a)). self assert: (mock foo: #(a b) bar: #(b b)). ! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 1/2/2004 11:16'! testEqualVariables1 category add: (self parse: 'aPMMock>>foo: x bar: x ^true'). category add: (self parse: 'aPMMock>>foo: x bar: y ^false'). self deny: (mock foo: 0 bar: 1). self assert: (mock foo: 0 bar: 0). ! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 18:37'! testObject1 category add: (self parse: 'aPMMock>>foo: #a ^true'). category add: (self parse: 'aPMMock>>foo: x ^false'). self assert: (mock foo: #a). self deny: (mock foo: #b). ! ! !PMBuildTest methodsFor: 'testing-real' stamp: 'lr 1/2/2004 12:14'! testMergesort " merge lists " category add: (self parse: 'aPMMock>>merge: aSequenceableCollection with: {} ^aSequenceableCollection'). category add: (self parse: 'aPMMock>>merge: {} with: aSequenceableCollection ^aSequenceableCollection'). category add: (self parse: 'aPMMock>>merge: {x|xs} with: {y|ys} if: [ x <= y ] ^{x} , (aPMMock merge: xs with: {y} , ys)'). category add: (self parse: 'aPMMock>>merge: {x|xs} with: {y|ys} if: [ x > y ] ^{y} , (aPMMock merge: ys with: {x} , xs)'). self assert: (mock merge: (0 to: 8 by: 2) with: (1 to: 9 by: 2)) = (0 to: 9) asArray. self assert: (mock merge: (1 to: 9 by: 2) with: (0 to: 8 by: 2)) = (0 to: 9) asArray. " split lists " category add: (self parse: 'aPMMock>>split: {} ^{ {}. {}. }'). category add: (self parse: 'aPMMock>>split: {x} ^{ {x}. {}. }'). category add: (self parse: 'aPMMock>>split: {x.y|ys} | rest | rest _ aPMMock split: ys. ^{ {x} , rest first. {y} , rest second. }'). self assert: (mock split: (0 to: 9)) = { (0 to: 8 by: 2) asArray. (1 to: 9 by: 2) asArray }. " merge sort " category add: (self parse: 'aPMMock>>mergesort: {} ^{}'). category add: (self parse: 'aPMMock>>mergesort: {x} ^{x}'). category add: (self parse: 'aPMMock>>mergesort: aSequenceableCollection | split | split _ aPMMock split: aSequenceableCollection. ^aPMMock merge: (aPMMock mergesort: split first) with: (aPMMock mergesort: split second)'). 23 timesRepeat: [ self assert: (mock mergesort: (1 to: 23) asArray shuffled) = (1 to: 23) asArray ]. ! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 19:25'! testClass2 category add: (self parse: 'aPMMock>>foo: aPMMock1 ^true'). category add: (self parse: 'aPMMock>>foo: x ^false'). self assert: (mock foo: mock). self deny: (mock foo: nil). ! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 18:30'! testBody3 category add: (self parse: 'aPMMock>>foo: a bar: b ^b'). self assert: (mock foo: false bar: true). self deny: (mock foo: true bar: false). ! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 18:27'! testCondition2 category add: (self parse: 'aPMMock>>foo: a if: [ aPMMock = a ] ^true'). category add: (self parse: 'aPMMock>>foo: a ^false'). self assert: (mock foo: mock). self deny: (mock foo: 0).! ! !PMBuildTest methodsFor: 'utility' stamp: 'lr 12/31/2003 17:00'! assert: aSelector in: anObject self assert: (anObject class includesSelector: aSelector)! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 19:27'! testVariable1 category add: (self parse: 'aPMMock>>foo: a bar: b ^a@b'). self assert: (mock foo: 1 bar: 2) = (1@2). self assert: (mock foo: 2 bar: 1) = (2@1). ! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 19:28'! testVariable2 category add: (self parse: 'aPMMock>>foo: a ^true'). category add: (self parse: 'aPMMock>>foo: b ^false'). self assert: (mock foo: nil). self assert: (mock foo: 1). self assert: (mock foo: 'abc').! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 22:25'! testEqualBlock1 category add: (self parse: 'aPMMock>>foo: [ :x | x ] bar: [ :x | x not ] ^#impossible'). category add: (self parse: 'aPMMock>>foo: [ :x | x ] bar: [ :y | y not ] ^true'). category add: (self parse: 'aPMMock>>foo: x bar: y ^false'). self deny: (mock foo: true bar: true). self deny: (mock foo: false bar: true). self assert: (mock foo: true bar: false). self deny: (mock foo: false bar: false).! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 19:47'! testOpenList2 category add: (self parse: 'aPMMock>>foo: {x.y|ys} ^ys'). category add: (self parse: 'aPMMock>>foo: x ^false'). self assert: (mock foo: #()) = false. self assert: (mock foo: #(a)) = false. self assert: (mock foo: #(a b)) = #(). self assert: (mock foo: #(a b c)) = #(c). ! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 18:27'! testCondition3 category add: (self parse: 'aPMMock>>foo: a bar: b if: [ a = b ] ^true'). category add: (self parse: 'aPMMock>>foo: a bar: b ^false'). self assert: (mock foo: 0 bar: 0 ). self deny: (mock foo: 0 bar: 1 ).! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 22:21'! testReceiverBlock2 category add: (self parse: '[ :x | (x isKindOf: Boolean) and: [ x ] ]>>foo ^true'). category add: (self parse: '[ :x | (x isKindOf: Boolean) and: [ x not ] ]>>foo ^false'). self assert: true foo. self deny: false foo. self should: [ nil foo ] raise: MessageNotUnderstood.! ! !PMBuildTest methodsFor: 'testing-real' stamp: 'lr 1/2/2004 12:08'! testHead category add: (self parse: '{x|xs}>>pmHead ^x'). self assert: #(a) pmHead = #a. self assert: #(a b) pmHead = #a. self assert: #(a b c) pmHead = #a.! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 22:02'! testReceiverVariable2 category add: (self parse: 'x>>foo if: [ x isKindOf: Boolean ] ^true'). category add: (self parse: 'y>>foo ^false'). self assert: true foo. self deny: #() foo. self deny: 0 foo.! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 19:36'! testList3 category add: (self parse: 'aPMMock>>foo: {x.y} ^x@y'). category add: (self parse: 'aPMMock>>foo: x ^false'). self assert: (mock foo: #()) = false. self assert: (mock foo: #(1)) = false. self assert: (mock foo: #(1 2)) = (1@2). self assert: (mock foo: #(1 2 3)) = false.! ! !PMBuildTest methodsFor: 'testing-real' stamp: 'lr 1/2/2004 12:08'! testTail category add: (self parse: '{x|xs}>>pmTail ^xs'). self assert: #(a) pmTail = #(). self assert: #(a b) pmTail = #(b). self assert: #(a b c) pmTail = #(b c).! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 22:54'! testBody5 category add: (self parse: 'aPMMock>>foo: {a|as} bar: {b|bs} ^{a.b} , as , bs'). self assert: (mock foo: #(1) bar: #(2)) = #(1 2). self assert: (mock foo: #(1 3) bar: #(2 4)) = #(1 2 3 4). self assert: (mock foo: #(1 3 4) bar: #(2)) = #(1 2 3 4).! ! !PMBuildTest methodsFor: 'running' stamp: 'lr 12/31/2003 16:58'! setUp mock _ PMMock new. category _ PMCategory name: 'Mock'.! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 18:38'! testObject2 category add: (self parse: 'aPMMock>>foo: 0 ^true'). category add: (self parse: 'aPMMock>>foo: x ^false'). self assert: (mock foo: 0). self deny: (mock foo: 1). ! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 22:25'! testEqualClass1 category add: (self parse: 'aPMMock>>foo: aPMMock1 bar: aPMMock1 ^true'). category add: (self parse: 'aPMMock>>foo: aPMMock1 bar: aPMMock2 ^false'). self deny: (mock foo: mock bar: PMMock new). self assert: (mock foo: mock bar: mock). ! ! !PMBuildTest methodsFor: 'testing-real' stamp: 'lr 1/2/2004 12:06'! testCompare category add: (self parse: '{x|xs}>>pmComp: {x|ys} ^xs pmComp: ys'). category add: (self parse: '{}>>pmComp: {} ^true'). category add: (self parse: 'x>>pmComp: y ^false'). self assert: (#() pmComp: #()). self assert: (#(a) pmComp: #(a)). self assert: (#(a b) pmComp: #(a b)). self assert: (#(a b c) pmComp: #(a b c)). self deny: (#(a) pmComp: #()). self deny: (#() pmComp: #(a)). self deny: (#(a) pmComp: #(b)). self deny: (#(a b) pmComp: #(a c)). self deny: (1 pmComp: 1). self deny: (false pmComp: false). ! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 19:24'! testBlock3 category add: (self parse: 'aPMMock>>foo: [ :x | x ] bar: [ :y | y ] ^true'). category add: (self parse: 'aPMMock>>foo: x bar: y ^false'). self deny: (mock foo: false bar: false). self deny: (mock foo: true bar: false). self deny: (mock foo: false bar: true). self assert: (mock foo: true bar: true). ! ! !PMBuildTest methodsFor: 'testing-real' stamp: 'lr 1/2/2004 12:14'! testQuicksort category add: (self parse: 'aPMMock>>quicksort: {} ^{}'). category add: (self parse: 'aPMMock>>quicksort: {x|xs} ^(self quicksort: (xs select: [ :each | each < x ])) , {x} , (self quicksort: (xs reject: [ :each | each < x ]))'). 23 timesRepeat: [ self assert: (mock quicksort: (1 to: 23) asArray shuffled) = (1 to: 23) asArray ]. ! ! !PMBuildTest methodsFor: 'testing-utility' stamp: 'lr 12/31/2003 17:01'! testLeastGeneralClass {Array} permutationsDo: [ :each | self assert: (category findLeastGeneralClass: each) == Array ]. {Array. String} permutationsDo: [ :each | self assert: (category findLeastGeneralClass: each) == ArrayedCollection ]. {Array. String. Interval} permutationsDo: [ :each | self assert: (category findLeastGeneralClass: each) == SequenceableCollection ]. {Array. String. Interval. Point} permutationsDo: [ :each | self assert: (category findLeastGeneralClass: each) == Object ]. {Array. String. Interval. Point. Integer} permutationsDo: [ :each | self assert: (category findLeastGeneralClass: each) == Object ].! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 19:25'! testClass1 category add: (self parse: 'aPMMock>>foo: aNumber ^true'). category add: (self parse: 'aPMMock>>foo: x ^false'). self assert: (mock foo: 100). self assert: (mock foo: 100 factorial). self assert: (mock foo: 100 sin). self assert: (mock foo: 100 reciprocal). self deny: (mock foo: 1@1). self deny: (mock foo: #()). ! ! !PMBuildTest methodsFor: 'utility' stamp: 'lr 12/31/2003 17:00'! assertCategories: aBlock Smalltalk allClasses do: [ :class | class organization categories do: [ :each | aBlock value: class value: each ] ]! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 19:22'! testBlock2 category add: (self parse: 'aPMMock>>foo: [ :x | (x isKindOf: Boolean) and: [ x ] ] ^true'). category add: (self parse: 'aPMMock>>foo: x ^false'). self deny: (mock foo: 0). self deny: (mock foo: false). self assert: (mock foo: true). ! ! !PMBuildTest methodsFor: 'testing-real' stamp: 'lr 1/2/2004 12:12'! testZip category add: (self parse: '{x|xs}>>pmZip: {y|ys} ^{x. y} , (xs pmZip: ys)'). category add: (self parse: 'x>>pmZip: y ^{}'). self assert: (#() pmZip: #()) = #(). self assert: (#(a) pmZip: #(1)) = #(a 1). self assert: (#(a b) pmZip: #(1 2)) = #(a 1 b 2). self assert: (#(a b c) pmZip: #(1 2 3)) = #(a 1 b 2 c 3). self assert: (#(a) pmZip: #(1 2 3)) = #(a 1). self assert: (#(a b c) pmZip: #(1)) = #(a 1). ! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 22:05'! testReceiverBlock1 category add: (self parse: '[ :x | x ]>>foo ^true'). category add: (self parse: '[ :x | x not ]>>foo ^false'). self assert: true foo. self deny: false foo.! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 17:34'! testEqualList1 category add: (self parse: 'aPMMock>>foo: {a} bar: {a} ^true'). category add: (self parse: 'aPMMock>>foo: {a} bar: {b} ^false'). self deny: (mock foo: #(a) bar: #(b)). self assert: (mock foo: #(a) bar: #(a)). ! ! !PMBuildTest methodsFor: 'testing-real' stamp: 'lr 1/2/2004 12:04'! testAckerman category add: (self parse: '0>>pmAck: anInteger ^anInteger + 1'). category add: (self parse: 'anInteger>>pmAck: 0 ^anInteger - 1 pmAck: 1'). category add: (self parse: 'anInteger1>>pmAck: anInteger2 ^anInteger1 - 1 pmAck: (anInteger1 pmAck: anInteger2 - 1)'). self assert: (0 pmAck: 0) = 1. self assert: (1 pmAck: 0) = 2. self assert: (0 pmAck: 1) = 2. self assert: (2 pmAck: 0) = 3. self assert: (1 pmAck: 1) = 3. self assert: (0 pmAck: 2) = 3. self assert: (3 pmAck: 0) = 5. self assert: (2 pmAck: 1) = 5. self assert: (1 pmAck: 2) = 4. self assert: (0 pmAck: 3) = 4. self assert: (4 pmAck: 0) = 13. self assert: (3 pmAck: 1) = 13. self assert: (2 pmAck: 2) = 7. self assert: (1 pmAck: 3) = 5. self assert: (0 pmAck: 4) = 5.! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 18:31'! testBody1 category add: (self parse: 'aPMMock>>foo ^true'). self assert: mock foo. ! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 22:15'! testReceiverOpenList1 category add: (self parse: '{}>>foo ^true'). category add: (self parse: '{x|xs}>>foo ^false'). self assert: #() foo. self deny: #(a) foo. self deny: #(a b) foo.! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 22:21'! testReceiverList2 category add: (self parse: '{x.y}>>foo ^y'). self assert: #(a b) foo = #b. self should: [ #() foo ] raise: MessageNotUnderstood. self should: [ #(a) foo ] raise: MessageNotUnderstood. self should: [ #(a b c) foo ] raise: MessageNotUnderstood.! ! PMBuildTest subclass: #PMCategoryTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Tests'! !PMCategoryTest methodsFor: 'testing' stamp: 'lr 12/7/2003 20:22'! testInitialState self assert: mock message isNil. self assert: #testFib: in: mock. self assert: category name = 'Mock'. self assert: category functions size = 2. self assert: category categoryName = '*Mock-Functional'. self assert: category groups size = 1.! ! !PMCategoryTest methodsFor: 'testing' stamp: 'lr 12/7/2003 21:03'! testMoveDown | first second | first _ category functions first. second _ category functions second. category moveDown: first. self assert: category functions first == second. self assert: category functions second == first. category moveDown: first. self assert: category functions first == second. self assert: category functions second == first.! ! !PMCategoryTest methodsFor: 'testing' stamp: 'lr 12/7/2003 21:03'! testMoveUp | first second | first _ category functions first. second _ category functions second. category moveUp: second. self assert: category functions first == second. self assert: category functions second == first. category moveUp: second. self assert: category functions first == second. self assert: category functions second == first.! ! !PMCategoryTest methodsFor: 'testing' stamp: 'lr 12/8/2003 22:55'! testRemove category remove: category functions first. self assert: category functions size = 1. self assert: #testFib: in: mock. category remove: category functions first. self assert: category functions size = 0. self deny: #testFib: in: mock.! ! !PMCategoryTest methodsFor: 'running' stamp: 'lr 12/31/2003 17:00'! setUp super setUp. category add: (self parse: 'aPMMock>>testFib: anInteger if: [ anInteger < 2 ] ^anInteger'). category add: (self parse: 'aPMMock>>testFib: anInteger ^(self fib: anInteger - 1) + (self fib: anInteger - 2)').! ! !PMCategoryTest methodsFor: 'testing' stamp: 'lr 12/8/2003 22:55'! testRemoveAll category removeAll. self assert: category functions size = 0. self deny: #testFib: in: mock.! ! !PMCategoryTest methodsFor: 'testing' stamp: 'lr 12/8/2003 22:55'! testAdd category add: (self parse: 'aPMMock>>testSize: {} ^0'). category add: (self parse: 'aPMMock>>testSize: {x|xs} ^self testSize: xs'). self assert: category functions size = 4. self assert: category groups size = 2. self assert: #testSize: in: mock. ! ! !PMCategoryTest methodsFor: 'testing' stamp: 'lr 12/7/2003 20:59'! testRenameTo category renameTo: 'MockTest'. self assert: category name = 'MockTest'. self assert: category categoryName = '*MockTest-Functional'. self assert: #testFib: in: mock. ! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 18:30'! testBody2 category add: (self parse: 'aPMMock>>foo: a ^a'). self assert: (mock foo: true). self deny: (mock foo: false). ! ! !PMBuildTest methodsFor: 'testing-real' stamp: 'lr 1/2/2004 12:10'! testIncludes category add: (self parse: '{}>>pmIncludes: x ^false'). category add: (self parse: '{x|xs}>>pmIncludes: x ^true'). category add: (self parse: '{x|xs}>>pmIncludes: y ^xs pmIncludes: y'). self assert: (#(a b c) pmIncludes: #a). self assert: (#(a b c) pmIncludes: #b). self assert: (#(a b c) pmIncludes: #c). self deny: (#(a b c) pmIncludes: #d). self deny: (#(a b c) pmIncludes: nil). ! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 19:35'! testOpenList1 category add: (self parse: 'aPMMock>>foo: {x|xs} ^xs'). category add: (self parse: 'aPMMock>>foo: x ^false'). self assert: (mock foo: #()) = false. self assert: (mock foo: #(a)) = #(). self assert: (mock foo: #(a b)) = #(b). self assert: (mock foo: #(a b c)) = #(b c). ! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 17:36'! testEqualOpenList1 category add: (self parse: 'aPMMock>>foo: {a|as} bar: {a|as} ^true'). category add: (self parse: 'aPMMock>>foo: {a|as} bar: {b|bs} ^false'). self deny: (mock foo: #(a b c) bar: #(b b c)). self deny: (mock foo: #(a b c) bar: #(a c c)). self assert: (mock foo: #(a b c) bar: #(a b c)). ! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 22:24'! testReceiverClass2 category add: (self parse: 'anInteger>>foo ^#number'). category add: (self parse: 'aFloat>>foo ^#float'). self assert: 100 foo = #number. self assert: 100 sin foo = #float. self should: [ 100 reciprocal foo ] raise: MessageNotUnderstood. self should: [ 100 isZero foo ] raise: MessageNotUnderstood.! ! !PMBuildTest methodsFor: 'utility' stamp: 'lr 12/31/2003 17:00'! assertSelectors: aBlock Smalltalk allClasses do: [ :class | class selectors do: [ :each | aBlock value: class value: each ] ]! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 18:40'! testObject4 category add: (self parse: 'aPMMock>>foo: ''abc'' ^true'). category add: (self parse: 'aPMMock>>foo: x ^false'). self assert: (mock foo: 'abc'). self deny: (mock foo: 'def'). ! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 18:24'! testCondition1 category add: (self parse: 'aPMMock>>foo: a if: [ a ] ^true'). category add: (self parse: 'aPMMock>>foo: a ^false'). self assert: (mock foo: true). self deny: (mock foo: false). ! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 19:34'! testList1 category add: (self parse: 'aPMMock>>foo: {} ^true'). category add: (self parse: 'aPMMock>>foo: x ^false'). self assert: (mock foo: #()). self deny: (mock foo: #(1)). self deny: (mock foo: #(1 2)).! ! !PMBuildTest methodsFor: 'testing-utility' stamp: 'lr 12/31/2003 17:01'! testDoesNotUnderstand category add: (self parse: 'aPMMock>>testNever if: [ false ]'). category add: (self parse: 'aPMMock>>testAlways if: [ true ]'). mock testNever. self assert: mock message selector = #testNever. mock testAlways. self assert: mock message selector = #testNever.! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 22:21'! testReceiverClass1 category add: (self parse: 'anInteger>>foo ^#integer'). category add: (self parse: 'aFloat>>foo ^#float'). category add: (self parse: 'aNumber>>foo ^#number'). self assert: 100 factorial foo = #integer. self assert: 100 sin foo = #float. self assert: 100 reciprocal foo = #number. self should: [ 100 isZero foo ] raise: MessageNotUnderstood! ! !PMBuildTest methodsFor: 'running' stamp: 'lr 12/31/2003 16:58'! tearDown category removeAll! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 19:47'! testOpenList3 category add: (self parse: 'aPMMock>>foo: {x|{y|ys}} ^ys'). category add: (self parse: 'aPMMock>>foo: x ^false'). self assert: (mock foo: #()) = false. self assert: (mock foo: #(a)) = false. self assert: (mock foo: #(a b)) = #(). self assert: (mock foo: #(a b c)) = #(c). ! ! !PMBuildTest methodsFor: 'utility' stamp: 'lr 12/31/2003 17:00'! deny: aSelector in: anObject self deny: (anObject class includesSelector: aSelector)! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 22:19'! testReceiverList1 category add: (self parse: '{}>>foo ^true'). category add: (self parse: '{x|xs}>>foo ^false'). self assert: #() foo. self deny: #(a) foo. self deny: #(a b) foo.! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 19:36'! testList2 category add: (self parse: 'aPMMock>>foo: {x} ^x'). category add: (self parse: 'aPMMock>>foo: x ^false'). self assert: (mock foo: #()) = false. self assert: (mock foo: #(1)) = 1. self assert: (mock foo: #(1 2)) = false.! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 1/2/2004 11:18'! testEqualVariables2 category add: (self parse: 'aPMMock>>foo: x bar: x zork: x ^true'). category add: (self parse: 'aPMMock>>foo: x bar: y zork: z ^false'). self deny: (mock foo: 0 bar: 1 zork: 1). self deny: (mock foo: 1 bar: 0 zork: 1). self deny: (mock foo: 1 bar: 1 zork: 0). self assert: (mock foo: 0 bar: 0 zork: 0). self assert: (mock foo: 1 bar: 1 zork: 1). ! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 17:33'! testEqualList3 category add: (self parse: 'aPMMock>>foo: {a.b} bar: {b.a} ^true'). category add: (self parse: 'aPMMock>>foo: {a.b} bar: {c.d} ^false'). self deny: (mock foo: #(a b) bar: #(a b)). self assert: (mock foo: #(a b) bar: #(b a)). ! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 19:42'! testEqualOpenList2 category add: (self parse: 'aPMMock>>foo: {a|as} equal: {a|as} ^true'). category add: (self parse: 'aPMMock>>foo: {a|as} equal: {b|bs} ^false'). self deny: (mock foo: #(0 1 2) equal: #(0 2 3)). self assert: (mock foo: #(0 1 2) equal: #(0 1 2)). ! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 22:00'! testReceiverClass3 category add: (self parse: 'aNumber>>foo ^#number'). category add: (self parse: 'aCollection>>foo ^#collection'). category add: (self parse: 'x>>foo ^#object'). self assert: 0 foo = #number. self assert: #() foo = #collection. self assert: true foo = #object.! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 22:01'! testReceiverVariable1 category add: (self parse: 'x>>foo ^true'). category add: (self parse: 'y>>foo ^false'). self assert: 0 foo. self assert: #() foo. self assert: true foo.! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 18:58'! testBlock1 category add: (self parse: 'aPMMock>>foo: [ :x | false ] ^false'). category add: (self parse: 'aPMMock>>foo: x ^true'). self assert: (mock foo: true). self assert: (mock foo: false). ! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 19:28'! testVariable3 category add: (self parse: 'aPMMock>>foo: a ^true'). category add: (self parse: 'aPMMock>>foo: a ^false'). self deny: (mock foo: nil). self deny: (mock foo: 1). self deny: (mock foo: 'abc').! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 18:38'! testObject3 category add: (self parse: 'aPMMock>>foo: $a ^true'). category add: (self parse: 'aPMMock>>foo: x ^false'). self assert: (mock foo: $a). self deny: (mock foo: $b). ! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 19:44'! testEqualOpenList3 category add: (self parse: 'aPMMock>>foo: {a|a} ^true'). category add: (self parse: 'aPMMock>>foo: x ^false'). self assert: (mock foo: #((0) 0)). self deny: (mock foo: #(0 0)). self deny: (mock foo: #(0 (0))). ! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 23:02'! testReceiverList3 category add: (self parse: '{aNumber}>>foo ^true'). category add: (self parse: '{x}>>foo ^false'). self assert: #(1) foo. self deny: #(a) foo. self deny: #($a) foo. self deny: #('a') foo. ! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 22:55'! testBody4 category add: (self parse: 'aPMMock>>foo: a bar: b ^{a.b}'). self assert: (mock foo: 0 bar: 1) = #(0 1). self assert: (mock foo: 1 bar: 0) = #(1 0). ! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 12/31/2003 18:40'! testObject5 category add: (self parse: 'aPMMock>>foo: true ^true'). category add: (self parse: 'aPMMock>>foo: false ^false'). category add: (self parse: 'aPMMock>>foo: nil ^false'). self assert: (mock foo: true). self deny: (mock foo: false). self deny: (mock foo: nil). ! ! !PMFunctionalTest methodsFor: 'utility' stamp: 'lr 12/2/2003 19:02'! parse: aString ^PMParser parse: aString! ! SmaCCParser subclass: #PMParser instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Parsing'! !PMParser class methodsFor: 'generated-comments' stamp: 'lr 12/31/2003 19:42'! parserDefinitionComment "Message : Pattern 'receiver' "">>"" Selector 'selector' Body 'body' { PMFunction receiver: receiver arguments: selector body: body } | Pattern 'receiver' "">>"" Selector 'selector' Condition 'condition' Body 'body' { PMFunction receiver: receiver arguments: selector condition: condition body: body } ; # S E L E C O R S # # # #Ê# # # # # #Ê# # # # # #Ê# # # # # #Ê# # # # # #Ê# # # # # #Ê# # # # # #Ê# # # # # #Ê# # Selector : UnarySelector | BinarySelector | KeywordSelector+ ; UnarySelector : { PMSelector selector: '1' value asSymbol } ; BinarySelector : Pattern { PMMatchedSelector selector: '1' value asSymbol pattern: '2' } ; KeywordSelector : Pattern { PMMatchedSelector selector: '1' value asSymbol pattern: '2' } ; # P A T T E R N # # # #Ê# # # # # #Ê# # # # # #Ê# # # # # #Ê# # # # # #Ê# # # # # #Ê# # # # # #Ê# # # # # #Ê# # Pattern : Object { #liftFirstValue: } | Class { #liftFirstValue: } | Variable { #liftFirstValue: } | List { #liftFirstValue: } | Block { #liftFirstValue: } ; Object : ""true"" { PMObjectPattern object: true } | ""false"" { PMObjectPattern object: false } | ""nil"" { PMObjectPattern object: nil } | { PMObjectPattern object: '1' value asNumber } | { PMObjectPattern object: '1' value second } | { PMObjectPattern object: '1' value allButFirst allButLast } | ""#"" { PMObjectPattern object: '2' value allButFirst allButLast asSymbol } | ""#"" { PMObjectPattern object: '2' value asSymbol } | ""#"" { PMObjectPattern object: '2' value asSymbol } | ""#"" { PMObjectPattern object: '2' value asSymbol } | ""#"" { PMObjectPattern object: '2' value asSymbol } ; Class : { PMClassPattern name: '1' value } ; Variable : { PMVariablePattern name: '1' value } ; List : ""{"" ""}"" { PMListPattern empty } | ""{"" ListEntries 'items' "".""? ""}"" { PMListPattern head: items } | ""{"" ListEntries 'items' "".""? ""|"" Pattern 'tail' ""}"" { PMOpenListPattern head: items tail: tail } ; ListEntries : Pattern 'pattern' { OrderedCollection with: pattern } | ListEntries 'list' ""."" Pattern 'pattern' { list add: pattern; yourself } ; Block : ""["" "":"" 'variable' ""|"" { PMBlockPattern name: variable value expression: self parseCondition } ; # S M A L L T A K # # # #Ê# # # # # #Ê# # # # # #Ê# # # # # #Ê# # # # # #Ê# # # # # #Ê# # # # # #Ê# # # # # #Ê# # Condition : ""if:"" ""["" { self parseCondition } ; Body : { self parseBody } ;"! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/31/2003 19:42'! reduceActionForObject11: nodes ^PMObjectPattern object: (nodes at: 2) value asSymbol! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/31/2003 19:42'! reduceActionForObject9: nodes ^PMObjectPattern object: (nodes at: 2) value asSymbol! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/31/2003 19:42'! reduceActionForBlock1: nodes ^PMBlockPattern name: (nodes at: 3) value expression: self parseCondition! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/31/2003 19:42'! reduceActionForMessage1: nodes ^PMFunction receiver: (nodes at: 1) arguments: (nodes at: 3) body: (nodes at: 4)! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/31/2003 19:42'! reduceActionForRepeatXMultipleXXKeywordSelector1: nodes ^OrderedCollection with: (nodes at: 1)! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/31/2003 19:42'! reduceActionForBinarySelector1: nodes ^PMMatchedSelector selector: (nodes at: 1) value asSymbol pattern: (nodes at: 2)! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/31/2003 19:42'! reduceActionForUnarySelector1: nodes ^PMSelector selector: (nodes at: 1) value asSymbol! ! !PMParser class methodsFor: 'generated-accessing' stamp: 'lr 12/31/2003 19:42'! scannerClass ^PMScanner! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/31/2003 19:42'! reduceActionForListEntries2: nodes ^(nodes at: 1) add: (nodes at: 3); yourself! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/31/2003 19:42'! reduceActionForMessage2: nodes ^PMFunction receiver: (nodes at: 1) arguments: (nodes at: 3) condition: (nodes at: 4) body: (nodes at: 5)! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/31/2003 19:42'! reduceActionForObject6: nodes ^PMObjectPattern object: (nodes at: 1) value allButFirst allButLast! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/31/2003 19:42'! reduceActionForCondition1: nodes ^self parseCondition! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/31/2003 19:42'! reduceActionForObject3: nodes ^PMObjectPattern object: nil! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/31/2003 19:42'! reduceActionForKeywordSelector1: nodes ^PMMatchedSelector selector: (nodes at: 1) value asSymbol pattern: (nodes at: 2)! ! !PMParser class methodsFor: 'generated-starting states' stamp: 'lr 12/31/2003 19:42'! startingStateForMessage ^1! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/31/2003 19:42'! reduceActionForOptionalXXXXX1: nodes ^nil! ! !PMParser methodsFor: 'generated-tables' stamp: 'lr 12/31/2003 19:42'! transitionTable ^#( #(3 9 1 13 3 17 5 21 6 25 7 29 8 33 13 37 14 41 15 45 16 49 21 53 25 57 26 61 27 65 28 69 29 73 30 77 35) #(2 38 2 4 9 11 12 17 38) #(2 30 2 4 9 11 12 17 38) #(2 34 2 4 9 11 12 17 38) #(3 81 14 85 16 89 17 93 18 97 19) #(3 9 1 13 3 17 5 21 6 25 7 29 8 101 11 33 13 37 14 41 15 45 16 49 21 57 26 61 27 65 28 69 29 73 30 105 35 109 36) #(2 113 10) #(2 74 2 4 9 11 12 17 38) #(2 78 2 4 9 11 12 17 38) #(2 42 2 4 9 11 12 17 38) #(2 50 2 4 9 11 12 17 38) #(2 46 2 4 9 11 12 17 38) #(2 0 38) #(2 122 2 4 9 11 12 17 38) #(2 126 2 4 9 11 12 17 38) #(2 130 2 4 9 11 12 17 38) #(2 134 2 4 9 11 12 17 38) #(2 138 2 4 9 11 12 17 38) #(2 117 4) #(2 58 2 4 9 11 12 17 38) #(2 54 2 4 9 11 12 17 38) #(2 66 2 4 9 11 12 17 38) #(2 70 2 4 9 11 12 17 38) #(2 62 2 4 9 11 12 17 38) #(2 82 2 4 9 11 12 17 38) #(2 142 9 11 12) #(3 150 9 150 11 121 12 125 37) #(2 129 14) #(3 133 14 137 17 141 19 145 22 149 23 153 32 157 34 161 40) #(3 9 1 13 3 17 5 21 6 25 7 29 8 154 9 154 11 33 13 37 14 41 15 45 16 49 21 57 26 61 27 65 28 69 29 73 30 165 35) #(3 169 9 173 11) #(2 177 9) #(2 14 2 38) #(3 9 1 13 3 17 5 21 6 25 7 29 8 33 13 37 14 41 15 45 16 49 21 57 26 61 27 65 28 69 29 73 30 181 35) #(3 9 1 13 3 17 5 21 6 25 7 29 8 33 13 37 14 41 15 45 16 49 21 57 26 61 27 65 28 69 29 73 30 185 35) #(3 118 2 137 17 189 32 118 38) #(2 110 2 38) #(2 6 2 17 38) #(3 193 2 197 31 201 33 106 38) #(2 114 2 38) #(2 146 9 11 12) #(3 9 1 13 3 17 5 21 6 25 7 29 8 33 13 37 14 41 15 45 16 49 21 57 26 61 27 65 28 69 29 73 30 205 35) #(2 86 2 4 9 11 12 17 38) #(2 94 2 4 9 11 12 17 38) #(2 102 2 17 38) #(2 158 2 38) #(2 10 2 17 38) #(2 209 8) #(3 213 33 106 38) #(2 22 38) #(2 217 11) #(2 98 38) #(2 26 38) #(2 90 2 4 9 11 12 17 38) )! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/31/2003 19:42'! reduceActionForClass1: nodes ^PMClassPattern name: (nodes at: 1) value! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/31/2003 19:42'! reduceActionForList3: nodes ^PMOpenListPattern head: (nodes at: 2) tail: (nodes at: 5)! ! !PMParser methodsFor: 'generated-tables' stamp: 'lr 12/31/2003 19:42'! reduceTable ^#( #(22 1 #reduceActionForRepeatXMultipleXXKeywordSelector1:) #(22 2 #reduceActionForRepeatXMultipleXXKeywordSelector2:) #(23 1 #reduceActionForUnarySelector1:) #(24 1 #reduceFor:) #(25 4 #reduceActionForMessage1:) #(25 5 #reduceActionForMessage2:) #(26 1 #reduceActionForObject1:) #(26 1 #reduceActionForObject2:) #(26 1 #reduceActionForObject3:) #(26 1 #reduceActionForObject4:) #(26 1 #reduceActionForObject5:) #(26 1 #reduceActionForObject6:) #(26 2 #reduceActionForObject7:) #(26 2 #reduceActionForObject8:) #(26 2 #reduceActionForObject9:) #(26 2 #reduceActionForObject10:) #(26 2 #reduceActionForObject11:) #(27 1 #reduceActionForClass1:) #(28 1 #reduceActionForVariable1:) #(29 2 #reduceActionForList1:) #(29 4 #reduceActionForList2:) #(29 6 #reduceActionForList3:) #(30 4 #reduceActionForBlock1:) #(31 2 #reduceActionForCondition1:) #(32 2 #reduceActionForKeywordSelector1:) #(33 0 #reduceActionForBody1:) #(34 1 #reduceFor:) #(34 1 #reduceFor:) #(34 1 #reduceFor:) #(35 1 #liftFirstValue:) #(35 1 #liftFirstValue:) #(35 1 #liftFirstValue:) #(35 1 #liftFirstValue:) #(35 1 #liftFirstValue:) #(36 1 #reduceActionForListEntries1:) #(36 3 #reduceActionForListEntries2:) #(37 0 #reduceActionForOptionalXXXXX1:) #(37 1 #reduceActionForOptionalXXXXX2:) #(40 2 #reduceActionForBinarySelector1:) )! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/31/2003 19:42'! reduceActionForObject1: nodes ^PMObjectPattern object: true! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/31/2003 19:42'! reduceActionForListEntries1: nodes ^OrderedCollection with: (nodes at: 1)! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/31/2003 19:42'! reduceActionForVariable1: nodes ^PMVariablePattern name: (nodes at: 1) value! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/31/2003 19:42'! reduceActionForObject5: nodes ^PMObjectPattern object: (nodes at: 1) value second! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/31/2003 19:42'! reduceActionForBody1: nodes ^self parseBody! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/31/2003 19:42'! reduceActionForList1: nodes ^PMListPattern empty! ! !PMParser methodsFor: 'actions' stamp: 'lr 12/4/2003 17:35'! parseExpression: anAssociation | source node | anAssociation isNil ifTrue: [ self reportError: 0 ]. source _ anAssociation value. node _ RBParser parseExpression: source onError: [ :error :position | scanner position: anAssociation key + (source size min: position). currentToken _ nil. self reportErrorMessage: error ]. currentToken _ scanner next. ^PMExpression source: source node: node! ! !PMParser methodsFor: 'actions' stamp: 'lr 12/3/2003 21:58'! parseCondition ^self parseExpression: (scanner scanBlockFrom: currentToken)! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/31/2003 19:42'! reduceActionForObject4: nodes ^PMObjectPattern object: (nodes at: 1) value asNumber! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/31/2003 19:42'! reduceActionForList2: nodes ^PMListPattern head: (nodes at: 2)! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/31/2003 19:42'! reduceActionForObject10: nodes ^PMObjectPattern object: (nodes at: 2) value asSymbol! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/31/2003 19:42'! reduceActionForObject7: nodes ^PMObjectPattern object: (nodes at: 2) value allButFirst allButLast asSymbol! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/31/2003 19:42'! reduceActionForObject2: nodes ^PMObjectPattern object: false! ! !PMParser methodsFor: 'actions' stamp: 'lr 12/3/2003 21:58'! parseBody ^self parseExpression: (scanner scanUpToEndFrom: currentToken)! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/31/2003 19:42'! reduceActionForObject8: nodes ^PMObjectPattern object: (nodes at: 2) value asSymbol! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/31/2003 19:42'! reduceActionForRepeatXMultipleXXKeywordSelector2: nodes ^(nodes at: 1) add: (nodes at: 2); yourself! ! !PMParser methodsFor: 'actions' stamp: 'lr 12/3/2003 18:46'! handleError: anInteger | result | 1 to: self emptySymbolTokenId do: [ :each | result _ self actionFor: each. (result bitAnd: self actionMask) = self reduceAction ifTrue: [ ^self reduce: (result bitShift: -2) ] ]. super handleError: anInteger! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/31/2003 19:42'! reduceActionForOptionalXXXXX2: nodes ^nodes at: 1! ! !UndefinedObject methodsFor: '*pattern' stamp: 'lr 12/3/2003 22:00'! acceptVisitor: aVisitor! ! !Integer methodsFor: '*Pattern-Examples-Functional' stamp: 'lr 1/2/2004 10:44'! fib "0>>fib ""10 fib"" ^0 " "1>>fib ^1" "anInteger>>fib if: [ anInteger > 1 ] ^(anInteger - 1) fib + (anInteger - 2) fib" self == 0 ifTrue: [^0]. self == 1 ifTrue: [^1]. self > 1 ifTrue: [^(self - 1) fib + (self - 2) fib]. ^self doesNotUnderstand: (Message selector: #fib arguments: { })! ! !RBArrayNode methodsFor: '*pattern' stamp: 'lr 12/31/2003 22:34'! forceStatements: aCollection statements _ nil. self statements: aCollection.! !