SystemOrganization addCategory: #'Pattern-Core'! SystemOrganization addCategory: #'Pattern-Parsing'! SystemOrganization addCategory: #'Pattern-Visitor'! SystemOrganization addCategory: #'Pattern-UI'! SystemOrganization addCategory: #'Pattern-Tests'! SmaCCParser subclass: #PMParser instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Parsing'! !PMParser class methodsFor: 'generated-comments' stamp: 'lr 2/9/2007 09:15'! 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 : Type 'type' { type } | Type 'type' ""as"" (|) 'name' { type alias: name value; yourself } ; Type : 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 class methodsFor: 'generated-accessing' stamp: 'lr 2/9/2007 09:15'! scannerClass ^PMScanner! ! !PMParser class methodsFor: 'generated-starting states' stamp: 'lr 2/9/2007 09:15'! startingStateForMessage ^1! ! !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: 'actions' stamp: 'lr 12/3/2003 21:58'! parseBody ^self parseExpression: (scanner scanUpToEndFrom: currentToken)! ! !PMParser methodsFor: 'actions' stamp: 'lr 12/3/2003 21:58'! parseCondition ^self parseExpression: (scanner scanBlockFrom: currentToken)! ! !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: 'generated-reduction actions' stamp: 'lr 2/9/2007 09:15'! reduceActionForBinarySelector1: nodes ^ PMMatchedSelector selector: (nodes at: 1) value asSymbol pattern: (nodes at: 2)! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 2/9/2007 09:15'! reduceActionForBlock1: nodes ^ PMBlockPattern name: (nodes at: 3) value expression: self parseCondition! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 2/9/2007 09:15'! reduceActionForBody1: nodes ^ self parseBody! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 2/9/2007 09:15'! reduceActionForClass1: nodes ^ PMClassPattern name: (nodes at: 1) value! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 2/9/2007 09:15'! reduceActionForCondition1: nodes ^ self parseCondition! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 2/9/2007 09:15'! reduceActionForGroupXXXXXXnameXXXXXclassnameX1: nodes ^ nodes at: 1! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 2/9/2007 09:15'! reduceActionForGroupXXXXXXnameXXXXXclassnameX2: nodes ^ nodes at: 1! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 2/9/2007 09:15'! reduceActionForKeywordSelector1: nodes ^ PMMatchedSelector selector: (nodes at: 1) value asSymbol pattern: (nodes at: 2)! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 2/9/2007 09:15'! reduceActionForList1: nodes ^ PMListPattern empty! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 2/9/2007 09:15'! reduceActionForList2: nodes ^ PMListPattern head: (nodes at: 2)! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 2/9/2007 09:15'! reduceActionForList3: nodes ^ PMOpenListPattern head: (nodes at: 2) tail: (nodes at: 5)! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 2/9/2007 09:15'! reduceActionForListEntries1: nodes ^ OrderedCollection with: (nodes at: 1)! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 2/9/2007 09:15'! reduceActionForListEntries2: nodes ^ (nodes at: 1) add: (nodes at: 3); yourself! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 2/9/2007 09:15'! reduceActionForMessage1: nodes ^ PMFunction receiver: (nodes at: 1) arguments: (nodes at: 3) body: (nodes at: 4)! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 2/9/2007 09:15'! 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 2/9/2007 09:15'! reduceActionForObject10: nodes ^ PMObjectPattern object: (nodes at: 2) value asSymbol! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 2/9/2007 09:15'! reduceActionForObject11: nodes ^ PMObjectPattern object: (nodes at: 2) value asSymbol! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 2/9/2007 09:15'! reduceActionForObject1: nodes ^ PMObjectPattern object: true! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 2/9/2007 09:15'! reduceActionForObject2: nodes ^ PMObjectPattern object: false! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 2/9/2007 09:15'! reduceActionForObject3: nodes ^ PMObjectPattern object: nil! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 2/9/2007 09:15'! reduceActionForObject4: nodes ^ PMObjectPattern object: (nodes at: 1) value asNumber! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 2/9/2007 09:15'! reduceActionForObject5: nodes ^ PMObjectPattern object: (nodes at: 1) value second! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 2/9/2007 09:15'! reduceActionForObject6: nodes ^ PMObjectPattern object: (nodes at: 1) value allButFirst allButLast! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 2/9/2007 09:15'! reduceActionForObject7: nodes ^ PMObjectPattern object: (nodes at: 2) value allButFirst allButLast asSymbol! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 2/9/2007 09:15'! reduceActionForObject8: nodes ^ PMObjectPattern object: (nodes at: 2) value asSymbol! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 2/9/2007 09:15'! reduceActionForObject9: nodes ^ PMObjectPattern object: (nodes at: 2) value asSymbol! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 2/9/2007 09:15'! reduceActionForOptionalXXXXX1: nodes ^ nil! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 2/9/2007 09:15'! reduceActionForOptionalXXXXX2: nodes ^ nodes at: 1! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 2/9/2007 09:15'! reduceActionForPattern1: nodes ^ nodes at: 1! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 2/9/2007 09:15'! reduceActionForPattern2: nodes ^ (nodes at: 1) alias: (nodes at: 3) value; yourself! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 2/9/2007 09:15'! reduceActionForRepeatXMultipleXXKeywordSelector1: nodes ^ OrderedCollection with: (nodes at: 1)! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 2/9/2007 09:15'! reduceActionForRepeatXMultipleXXKeywordSelector2: nodes ^ (nodes at: 1) add: (nodes at: 2); yourself! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 2/9/2007 09:15'! reduceActionForUnarySelector1: nodes ^ PMSelector selector: (nodes at: 1) value asSymbol! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 2/9/2007 09:15'! reduceActionForVariable1: nodes ^ PMVariablePattern name: (nodes at: 1) value! ! !PMParser methodsFor: 'generated-tables' stamp: 'lr 2/9/2007 09:15'! reduceTable ^#( #(23 1 #reduceActionForRepeatXMultipleXXKeywordSelector1:) #(23 2 #reduceActionForRepeatXMultipleXXKeywordSelector2:) #(24 1 #reduceActionForUnarySelector1:) #(25 1 #reduceFor:) #(26 4 #reduceActionForMessage1:) #(26 5 #reduceActionForMessage2:) #(27 1 #liftFirstValue:) #(27 1 #liftFirstValue:) #(27 1 #liftFirstValue:) #(27 1 #liftFirstValue:) #(27 1 #liftFirstValue:) #(28 2 #reduceActionForCondition1:) #(29 1 #reduceActionForGroupXXXXXXnameXXXXXclassnameX1:) #(29 1 #reduceActionForGroupXXXXXXnameXXXXXclassnameX2:) #(30 1 #reduceActionForObject1:) #(30 1 #reduceActionForObject2:) #(30 1 #reduceActionForObject3:) #(30 1 #reduceActionForObject4:) #(30 1 #reduceActionForObject5:) #(30 1 #reduceActionForObject6:) #(30 2 #reduceActionForObject7:) #(30 2 #reduceActionForObject8:) #(30 2 #reduceActionForObject9:) #(30 2 #reduceActionForObject10:) #(30 2 #reduceActionForObject11:) #(31 1 #reduceActionForClass1:) #(32 1 #reduceActionForVariable1:) #(33 2 #reduceActionForList1:) #(33 4 #reduceActionForList2:) #(33 6 #reduceActionForList3:) #(34 4 #reduceActionForBlock1:) #(35 0 #reduceActionForBody1:) #(36 2 #reduceActionForBinarySelector1:) #(37 1 #reduceFor:) #(37 1 #reduceFor:) #(37 1 #reduceFor:) #(38 1 #reduceActionForPattern1:) #(38 3 #reduceActionForPattern2:) #(39 1 #reduceActionForListEntries1:) #(39 3 #reduceActionForListEntries2:) #(40 0 #reduceActionForOptionalXXXXX1:) #(40 1 #reduceActionForOptionalXXXXX2:) #(43 2 #reduceActionForKeywordSelector1:) )! ! !PMParser methodsFor: 'generated-tables' stamp: 'lr 2/9/2007 09:15'! transitionTable ^#( #(3 9 1 13 2 17 4 21 6 25 8 29 9 33 14 37 15 41 16 45 17 49 22 53 26 57 27 61 30 65 31 69 32 73 33 77 34 81 38) #(2 70 3 5 7 11 12 13 18 41) #(2 66 3 5 7 11 12 13 18 41) #(3 85 15 89 17 93 18 97 19 101 20) #(2 62 3 5 7 11 12 13 18 41) #(3 9 1 13 2 17 4 21 6 25 8 29 9 105 12 33 14 37 15 41 16 45 17 49 22 57 27 61 30 65 31 69 32 73 33 77 34 109 38 113 39) #(2 117 10) #(2 106 3 5 7 11 12 13 18 41) #(2 110 3 5 7 11 12 13 18 41) #(2 74 3 5 7 11 12 13 18 41) #(2 82 3 5 7 11 12 13 18 41) #(2 78 3 5 7 11 12 13 18 41) #(2 0 41) #(3 150 3 150 5 121 7 150 11 150 12 150 13 150 18 150 41) #(2 30 3 5 7 11 12 13 18 41) #(2 34 3 5 7 11 12 13 18 41) #(2 38 3 5 7 11 12 13 18 41) #(2 42 3 5 7 11 12 13 18 41) #(2 46 3 5 7 11 12 13 18 41) #(2 125 5) #(2 90 3 5 7 11 12 13 18 41) #(2 86 3 5 7 11 12 13 18 41) #(2 98 3 5 7 11 12 13 18 41) #(2 102 3 5 7 11 12 13 18 41) #(2 94 3 5 7 11 12 13 18 41) #(2 114 3 5 7 11 12 13 18 41) #(2 158 11 12 13) #(3 166 11 166 12 129 13 133 40) #(2 137 15) #(3 141 14 145 15 149 29) #(3 153 15 157 18 161 20 165 23 169 24 173 36 177 37 181 43) #(3 9 1 13 2 17 4 21 6 25 8 29 9 170 11 170 12 33 14 37 15 41 16 45 17 49 22 57 27 61 30 65 31 69 32 73 33 77 34 185 38) #(3 189 11 193 12) #(2 197 11) #(2 58 3 5 11 12 13 18 41) #(2 54 3 5 11 12 13 18 41) #(2 154 3 5 11 12 13 18 41) #(2 14 3 41) #(3 9 1 13 2 17 4 21 6 25 8 29 9 33 14 37 15 41 16 45 17 49 22 57 27 61 30 65 31 69 32 73 33 77 34 201 38) #(3 9 1 13 2 17 4 21 6 25 8 29 9 33 14 37 15 41 16 45 17 49 22 57 27 61 30 65 31 69 32 73 33 77 34 205 38) #(3 146 3 157 18 146 41 209 43) #(2 138 3 41) #(2 142 3 41) #(3 213 3 217 28 221 35 130 41) #(2 6 3 18 41) #(2 162 11 12 13) #(3 9 1 13 2 17 4 21 6 25 8 29 9 33 14 37 15 41 16 45 17 49 22 57 27 61 30 65 31 69 32 73 33 77 34 225 38) #(2 118 3 5 7 11 12 13 18 41) #(2 126 3 5 7 11 12 13 18 41) #(2 174 3 18 41) #(2 134 3 41) #(2 10 3 18 41) #(2 229 9) #(3 233 35 130 41) #(2 22 41) #(2 237 12) #(2 50 41) #(2 26 41) #(2 122 3 5 7 11 12 13 18 41) )! ! !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 class methodsFor: 'generated-initialization' stamp: 'lr 2/9/2007 09:15'! initializeKeywordMap keywordMap := Dictionary new. #( #(15 'as' 7 ) #(15 'false' 2 ) #(15 'nil' 1 ) #(15 'true' 6 ) #(20 '>>' 5 ) #(18 'if:' 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 2/9/2007 09:15'! scannerDefinitionComment " : [a] [n]? [A-Z] [a-zA-Z0-9]* ; : [a-zA-Z] [a-zA-Z0-9]* ; : [\-]? [0-9]+ (\. [0-9]+)? ; : \' [^\']* \' (\' [^\']* \')* ; : \: ; : \: ( \: )+ ; : [\~\-\!!\@\%\&\*\+\=\\\|\?\/\>\<\,] [\~\!!\@\%\&\*\+\=\\\|\?\/\>\<\,]? ; : \s+ ; : \$ . ; : . ;"! ! !PMScanner methodsFor: 'generated-tokens' stamp: 'lr 2/9/2007 09:15'! emptySymbolTokenId ^41! ! !PMScanner methodsFor: 'generated-tokens' stamp: 'lr 2/9/2007 09:15'! errorTokenId ^42! ! !PMScanner methodsFor: 'generated-scanner' stamp: 'lr 2/9/2007 09:15'! scan1 [self recordMatch: #(16 ). self step. currentCharacter between: $0 and: $9] whileTrue. currentCharacter = $. ifTrue: [self step. (currentCharacter between: $0 and: $9) ifTrue: [ [self recordMatch: #(16 ). self step. currentCharacter between: $0 and: $9] whileTrue. ^ self reportLastMatch]. ^ self reportLastMatch]. ^ self reportLastMatch! ! !PMScanner methodsFor: 'generated-scanner' stamp: 'lr 2/9/2007 09:15'! scan2 [self recordMatch: #(15 ). self step. (currentCharacter between: $0 and: $9) or: [(currentCharacter between: $A and: $Z) or: [currentCharacter between: $a and: $z]]] whileTrue. currentCharacter = $: ifTrue: [^ self scan3]. ^ self reportLastMatch! ! !PMScanner methodsFor: 'generated-scanner' stamp: 'lr 2/9/2007 09:15'! scan3 self recordMatch: #(18 ). self step. ((currentCharacter between: $A and: $Z) or: [currentCharacter between: $a and: $z]) ifTrue: [^ self scan4]. ^ self reportLastMatch! ! !PMScanner methodsFor: 'generated-scanner' stamp: 'lr 2/9/2007 09:15'! scan4 [self step. (currentCharacter between: $0 and: $9) or: [(currentCharacter between: $A and: $Z) or: [currentCharacter between: $a and: $z]]] whileTrue. currentCharacter = $: ifTrue: [self recordMatch: #(19 ). self step. ((currentCharacter between: $A and: $Z) or: [currentCharacter between: $a and: $z]) ifTrue: [^ self scan4]. ^ self reportLastMatch]. ^ self reportLastMatch! ! !PMScanner methodsFor: 'generated-scanner' stamp: 'lr 2/9/2007 09:15'! scan5 [self recordMatch: #(14 15 ). self step. (currentCharacter between: $0 and: $9) or: [(currentCharacter between: $A and: $Z) or: [currentCharacter between: $a and: $z]]] whileTrue. currentCharacter = $: ifTrue: [^ self scan3]. ^ self reportLastMatch! ! !PMScanner methodsFor: 'generated-scanner' stamp: 'lr 2/9/2007 09:15'! scan6 [self step. currentCharacter ~= $'] whileTrue. currentCharacter = $' ifTrue: [self recordMatch: #(17 ). self step. currentCharacter = $' ifTrue: [^ self scan6]. ^ self reportLastMatch]. ^ self reportLastMatch! ! !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: '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: 'generated-scanner' stamp: 'lr 2/9/2007 09:15'! scanForToken self step. ((currentCharacter between: $A and: $Z) or: [currentCharacter between: $b and: $z]) ifTrue: [^ self scan2]. (currentCharacter = $!! or: [(currentCharacter between: $% and: $&) or: [(currentCharacter between: $* and: $,) or: [currentCharacter = $/ or: [(currentCharacter between: $< and: $@) or: [currentCharacter = $\ or: [currentCharacter = $~]]]]]]) ifTrue: [self recordMatch: #(20 ). 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: #(20 )]. ^ self reportLastMatch]. (currentCharacter between: $0 and: $9) ifTrue: [^ self scan1]. ((currentCharacter between: Character tab and: Character cr) or: [currentCharacter = Character space]) ifTrue: [ [self recordMatch: #whitespace. self step. (currentCharacter between: Character tab and: Character cr) or: [currentCharacter = Character space]] whileTrue. ^ self reportLastMatch]. currentCharacter = $# ifTrue: [^ self recordAndReportMatch: #(4 )]. currentCharacter = $$ ifTrue: [self step. currentCharacter <= $ÿ ifTrue: [^ self recordAndReportMatch: #(22 )]. ^ self reportLastMatch]. currentCharacter = $' ifTrue: [^ self scan6]. currentCharacter = $- ifTrue: [self recordMatch: #(20 ). 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: #(20 )]. (currentCharacter between: $0 and: $9) ifTrue: [^ self scan1]. ^ self reportLastMatch]. currentCharacter = $. ifTrue: [^ self recordAndReportMatch: #(13 )]. currentCharacter = $: ifTrue: [^ self recordAndReportMatch: #(10 )]. currentCharacter = $[ ifTrue: [^ self recordAndReportMatch: #(9 )]. currentCharacter = $a ifTrue: [self recordMatch: #(15 ). self step. ((currentCharacter between: $0 and: $9) or: [(currentCharacter between: $a and: $m) or: [currentCharacter between: $o and: $z]]) ifTrue: [^ self scan2]. (currentCharacter between: $A and: $Z) ifTrue: [^ self scan5]. currentCharacter = $: ifTrue: [^ self scan3]. currentCharacter = $n ifTrue: [self recordMatch: #(15 ). self step. ((currentCharacter between: $0 and: $9) or: [currentCharacter between: $a and: $z]) ifTrue: [^ self scan2]. (currentCharacter between: $A and: $Z) ifTrue: [^ self scan5]. currentCharacter = $: ifTrue: [^ self scan3]. ^ self reportLastMatch]. ^ self reportLastMatch]. currentCharacter = ${ ifTrue: [^ self recordAndReportMatch: #(8 )]. currentCharacter = $| ifTrue: [self recordMatch: #(11 20 ). 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: #(20 )]. ^ self reportLastMatch]. currentCharacter = $} ifTrue: [^ self recordAndReportMatch: #(12 )]. ^ self reportLastMatch! ! !PMScanner methodsFor: 'actions' stamp: 'lr 12/3/2003 22:39'! scanUpToEndFrom: aToken self scanBackwardsFrom: aToken. ^stream position -> stream upToEnd asString! ! MCTool subclass: #PMBrowser instanceVariableNames: 'categories categorySelection selectors selectorSelection functions functionSelection textMorph source sourceSelection' classVariableNames: '' poolDictionaries: '' category: 'Pattern-UI'! !PMBrowser class methodsFor: 'instance creation' stamp: 'lr 12/9/2003 20:01'! open "self open" self new initialize; show; refresh! ! !PMBrowser methodsFor: 'actions' stamp: 'lr 1/18/2004 12:23'! 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: 'actions' stamp: 'lr 2/9/2007 08:54'! addFunction functionSelection := 0. self source: PMFunction template asText. self selection: (1 to: source size). self changed: #functionSelection. self changed: #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: 'morphic ui' stamp: 'lr 12/9/2003 20:38'! buildWindow ^super buildWindow paneColor: self windowColor; yourself! ! !PMBrowser methodsFor: 'building' stamp: 'lr 2/9/2007 09:42'! buildWith: aBuilder | window | window := aBuilder pluggableWindowSpec new model: self; label: self label; extent: self extent; children: (OrderedCollection new add: ((self buildCategoriesWith: aBuilder) frame: (0.00 @ 0.00 corner: 0.25 @ 0.92 ); yourself); add: ((self buildClassesWith: aBuilder) frame: (0.25 @ 0.00 corner: 0.50 @ 0.92 ); yourself); add: ((self buildStatusWith: aBuilder) frame: (0.50 @ 0.00 corner: 1.00 @ 0.08); yourself); add: ((self buildFailureListWith: aBuilder) frame: (0.50 @ 0.08 corner: 1.00 @ 0.50); yourself); add: ((self buildErrorListWith: aBuilder) frame: (0.50 @ 0.50 corner: 1.00 @ 0.92); yourself); add: ((self buildButtonsWith: aBuilder) frame: (0.00 @ 0.92 corner: 1.00 @ 1.00); yourself); yourself); yourself. ^ aBuilder build: window! ! !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: 'accessing' stamp: 'lr 1/18/2004 12:13'! category ^self hasSelectedCategory ifTrue: [ categories at: categorySelection ] ifFalse: [ nil ]! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 1/18/2004 12:05'! categoryList ^categories collect: [ :each | each name ]! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 1/18/2004 12:04'! categoryList: anOrderedCollection categories := anOrderedCollection asSortedCollection: [ :x :y | x name < y name ]. self changed: #categoryList.! ! !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 13:28'! categorySelection ^categorySelection! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 1/18/2004 12:09'! categorySelection: anInteger self hasChanges ifFalse: [ categorySelection := anInteger. self changed: #categorySelection. self selectorSelection: 0. categorySelection isZero ifTrue: [ self selectorList: Array new ] ifFalse: [ self selectorList: self category selectors ] ]! ! !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 09:15'! defaultLabel ^'Function Browser'! ! !PMBrowser methodsFor: 'accessing' stamp: 'lr 1/18/2004 12:13'! function ^self hasSelectedFunction ifTrue: [ functions at: functionSelection ] ifFalse: [ nil ]! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 1/18/2004 11:57'! functionList ^functions collect: [ :each | each printString ]! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 1/18/2004 12:02'! functionList: anOrderedCollection functions := anOrderedCollection. self changed: #functionList.! ! !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 13:45'! functionSelection ^functionSelection! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 1/18/2004 12:35'! functionSelection: anInteger self hasChanges ifFalse: [ functionSelection := anInteger. self changed: #functionSelection. functionSelection isZero ifTrue: [ self addFunction. self selection: (1 to: source size) ] ifFalse: [ self source: (functions at: functionSelection) asText. self selection: (1 to: 0) ] ]! ! !PMBrowser methodsFor: 'testing' stamp: 'lr 12/4/2003 14:07'! hasChanges self changed: #wantToChange. ^self canDiscardEdits not ! ! !PMBrowser methodsFor: 'testing' stamp: 'lr 12/4/2003 11:21'! hasSelectedCategory ^self categorySelection isZero not! ! !PMBrowser methodsFor: 'testing' stamp: 'lr 12/4/2003 11:21'! hasSelectedFunction ^self functionSelection isZero not! ! !PMBrowser methodsFor: 'testing' stamp: 'lr 1/18/2004 11:24'! hasSelectedSelector ^self selectorSelection isZero not! ! !PMBrowser methodsFor: 'initialization' stamp: 'lr 2/9/2007 09:49'! initialize super initialize. categories := OrderedCollection new. categorySelection := 0. selectors := OrderedCollection new. selectorSelection := 0. functions := OrderedCollection new. functionSelection := 0. source := String new. sourceSelection := 1 to: 0! ! !PMBrowser methodsFor: 'actions' stamp: 'lr 1/18/2004 14:01'! moveDownFunction | selection | selection := self functionSelection. (self hasSelectedFunction and: [ selection < self category functions size ]) ifTrue: [ self category moveDown: self function. self selectorSelection: self selectorSelection. self functionSelection: selection + 1 ]! ! !PMBrowser methodsFor: 'actions' stamp: 'lr 1/18/2004 14:01'! moveUpFunction | selection | selection := self functionSelection. (self hasSelectedFunction and: [ selection > 1 ]) ifTrue: [ self category moveUp: self function. self selectorSelection: self selectorSelection. self functionSelection: selection - 1 ]! ! !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: 'actions' stamp: 'lr 1/18/2004 12:06'! refresh self categoryList: PMCategory allCategories. self categorySelection: 0.! ! !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 1/18/2004 12:47'! removeFunction | selector | self hasSelectedFunction ifTrue: [ selector := self function selector. self category remove: self function. self categorySelection: (self categorySelection). self selectorSelection: (selectors indexOf: selector). self addFunction ]! ! !PMBrowser methodsFor: 'actions' stamp: 'lr 1/18/2004 13:04'! removeSelector self hasSelectedSelector ifTrue: [ (PopUpMenu confirm: 'Are you sure you want to remove this selector and all its functions?') ifTrue: [ functions do: [ :each | self category remove: each ]. self categorySelection: self categorySelection. self addFunction ] ]! ! !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: 'utility' stamp: 'lr 12/4/2003 15:02'! selection: aSelection sourceSelection := aSelection. self changed: #sourceSelection.! ! !PMBrowser methodsFor: 'accessing' stamp: 'lr 1/18/2004 12:16'! selector ^self hasSelectedSelector ifTrue: [ selectors at: selectorSelection ] ifFalse: [ nil ]! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 1/18/2004 12:05'! selectorList ^selectors collect: [ :each | each asString ]! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 1/18/2004 12:03'! selectorList: anOrderedCollection selectors := anOrderedCollection asSortedCollection. selectors isEmpty ifFalse: [ selectors := (Array with: ClassOrganizer allCategory) , selectors ]. self changed: #selectorList.! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 1/18/2004 13:01'! selectorListMenu: aMenu ^aMenu add: 'remove' target: self selector: #removeSelector; yourself ! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 1/18/2004 11:26'! selectorSelection ^selectorSelection! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 1/18/2004 12:14'! selectorSelection: anInteger self hasChanges ifFalse: [ selectorSelection := anInteger. self changed: #selectorSelection. self functionSelection: 0. selectorSelection isZero ifTrue: [ self functionList: Array new ] ifFalse: [ self functionList: (self category functionsFor: self selector) ] ]! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 2/9/2007 08:54'! source ^ source! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 2/9/2007 09:35'! source: aString source := aString. self changed: #sourceString ! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 12/4/2003 12:09'! sourceMenu: aMenu shifted: aBoolean ^StringHolder new codePaneMenu: aMenu shifted: aBoolean! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 12/4/2003 13:59'! sourceSelection ^sourceSelection! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 2/9/2007 09:35'! sourceString ^source! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 2/9/2007 09:35'! 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 selectorList: self category selectors ]. self source: aString. self selectorSelection: (selectors indexOf: function selector). self functionSelection: (functions indexOf: function) ] ]! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 2/9/2007 09:40'! 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 2/9/2007 09:39'! widgetSpecs self halt. ^#( ((listMorph: category) (0 0 0.2 0.4) (0 0 0 -30)) ((listMorph: selector) (0.2 0 0.4 0.4) (0 0 0 -30)) ((listMorph: function) (0.4 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: 'morphic ui' stamp: 'lr 12/9/2003 20:42'! windowColor ^Color blue mixed: 0.5 with: Color white! ! !RBArrayNode methodsFor: '*pattern' stamp: 'lr 12/31/2003 22:34'! forceStatements: aCollection statements := nil. self statements: aCollection.! ! TestCase subclass: #PMFunctionalTest instanceVariableNames: 'function' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Tests'! PMFunctionalTest subclass: #PMBuildTest instanceVariableNames: 'category mock' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Tests'! !PMBuildTest methodsFor: 'utility' stamp: 'lr 12/31/2003 17:00'! assert: aSelector in: anObject self assert: (anObject class includesSelector: aSelector)! ! !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: '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: 'utility' stamp: 'lr 12/31/2003 17:00'! deny: aSelector in: anObject self deny: (anObject class includesSelector: aSelector)! ! !PMBuildTest methodsFor: 'running' stamp: 'lr 12/31/2003 16:58'! setUp mock := PMMock new. category := PMCategory name: 'Mock'.! ! !PMBuildTest methodsFor: 'running' stamp: 'lr 12/31/2003 16:58'! tearDown category removeAll! ! !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: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: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' 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' 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 18:30'! testBody2 category add: (self parse: 'aPMMock>>foo: a ^a'). self assert: (mock foo: true). self deny: (mock foo: false). ! ! !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 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 1/11/2004 16:59'! testBody5 category add: (self parse: 'aPMMock>>foo: {x|xs} bar: {y|ys} ^{x.y} , xs , ys'). 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: '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: '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-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 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 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: '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-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: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 1/11/2004 17:21'! testEqualBlock2 category add: (self parse: 'aPMMock>>foo: [ :x | x ] as a bar: [ :x | x not ] as a ^#impossible'). category add: (self parse: 'aPMMock>>foo: [ :x | x ] as a bar: [ :y | y not ] as b ^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 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' stamp: 'lr 1/11/2004 17:20'! testEqualClass2 category add: (self parse: 'aPMMock>>foo: aPMMock as a bar: aPMMock as a ^true'). category add: (self parse: 'aPMMock>>foo: aPMMock as a bar: aPMMock as b ^false'). self deny: (mock foo: mock bar: PMMock new). self assert: (mock foo: mock bar: mock). ! ! !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' 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 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 1/11/2004 17:18'! testEqualList4 category add: (self parse: 'aPMMock>>foo: {x as a. x as b} bar: {x as b. x as 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 1/11/2004 17:32'! testEqualList5 category add: (self parse: 'aPMMock>>foo: {a.b} as l bar: {c.d} as l ^true'). category add: (self parse: 'aPMMock>>foo: {a.b} bar: {c.d} ^false'). self assert: (mock foo: #(a b) bar: #(a b)). self deny: (mock foo: #(a b) bar: #(b a)). ! ! !PMBuildTest methodsFor: 'testing' stamp: 'lr 1/11/2004 17:01'! testEqualOpenList1 category add: (self parse: 'aPMMock>>foo: {x|xs} bar: {x|xs} ^true'). category add: (self parse: 'aPMMock>>foo: {x|xs} bar: {y|ys} ^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 1/11/2004 17:01'! testEqualOpenList2 category add: (self parse: 'aPMMock>>foo: {x|xs} equal: {x|xs} ^true'). category add: (self parse: 'aPMMock>>foo: {x|xs} equal: {y|ys} ^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 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 1/11/2004 17:16'! testEqualOpenList4 category add: (self parse: 'aPMMock>>foo: {x|xs} as l1 equal: {y|ys} as l1 ^true'). category add: (self parse: 'aPMMock>>foo: {x|xs} as l1 equal: {y|ys} as l2 ^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 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 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 1/11/2004 17:17'! testEqualVariables3 category add: (self parse: 'aPMMock>>foo: a as x bar: b as x zork: c as x ^true'). category add: (self parse: 'aPMMock>>foo: a bar: b zork: c ^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-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-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-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: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' 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 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 2/9/2007 09:38'! 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 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' 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 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 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: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). ! ! !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 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 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: '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' 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 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' 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: '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: '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: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 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 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: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: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 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-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 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 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-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 subclass: #PMCategoryTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Tests'! !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'! 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: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: '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/7/2003 20:59'! testRenameTo category renameTo: 'MockTest'. self assert: category name = 'MockTest'. self assert: category categoryName = '*MockTest-Functional'. self assert: #testFib: in: mock. ! ! !PMFunctionalTest methodsFor: 'utility' stamp: 'lr 1/10/2004 20:16'! assert: anObject equals: anotherObject self assert: anObject = anotherObject! ! !PMFunctionalTest methodsFor: 'utility' stamp: 'lr 2/9/2007 08:41'! parse: aString ^ PMParser parse: aString! ! !PMFunctionalTest methodsFor: 'running' stamp: 'lr 2/9/2007 08:42'! runCase SystemChangeNotifier uniqueInstance doSilently: [ super runCase ]! ! PMFunctionalTest subclass: #PMParserTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Tests'! !PMParserTest methodsFor: 'testing-errors' stamp: 'lr 1/11/2004 15:34'! testAliasError self should: [ self parse: 'a as>>foo: b' ] raise: SmaCCParserError. self should: [ self parse: 'a>>foo: b as' ] 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 1/11/2004 15:35'! testBlock function := self parse: 'a>>foo: [ :b | b ] as c'. 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 alias = 'c'. 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 '.! ! !PMParserTest methodsFor: 'testing-errors' 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-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-errors' 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-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-pattern' stamp: 'lr 1/11/2004 15:17'! 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 alias = nil. self assert: function arguments first pattern target == Point. function := self parse: 'a>>foo: anInteger as b'. 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 alias = 'b'. self assert: function arguments first pattern target == Integer. ! ! !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-errors' 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'! 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-pattern' stamp: 'lr 1/11/2004 15:23'! testList function := self parse: 'a>>foo: {} as b'. 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 = true. self assert: function arguments first pattern name = nil. self assert: function arguments first pattern alias = 'b'. function := self parse: 'a>>foo: {x as b} as c'. 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 assert: function arguments first pattern isEmpty = false. self assert: function arguments first pattern name = nil. self assert: function arguments first pattern alias = 'c'. 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 first alias = 'b'. function := self parse: 'a>>foo: {x.y as b}'. 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 assert: function arguments first pattern isEmpty = false. self assert: function arguments first pattern name = nil. self assert: function arguments first pattern alias = nil. 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 first alias = nil. 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'. self assert: function arguments first pattern items second alias = 'b'. ! ! !PMParserTest methodsFor: 'testing-errors' 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 2/9/2007 08: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 includesBehavior: True). self assert: function arguments first pattern object = true. self assert: function arguments first pattern name = nil. self assert: function arguments first pattern alias = nil. 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 includesBehavior: False). self assert: function arguments first pattern object = false. self assert: function arguments first pattern name = nil. self assert: function arguments first pattern alias = nil. function := self parse: 'a>>foo: nil as b'. 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 includesBehavior: UndefinedObject). self assert: function arguments first pattern object = nil. self assert: function arguments first pattern name = nil. self assert: function arguments first pattern alias = 'b'. function := self parse: 'a>>foo: 123 as b'. 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 includesBehavior: SmallInteger). self assert: function arguments first pattern object = 123. self assert: function arguments first pattern name = nil. self assert: function arguments first pattern alias = 'b'. 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 includesBehavior: Float). self assert: function arguments first pattern object = 1.23. self assert: function arguments first pattern name = nil. self assert: function arguments first pattern alias = nil. 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 includesBehavior: Symbol). self assert: function arguments first pattern object = #abc. self assert: function arguments first pattern name = nil. self assert: function arguments first pattern alias = nil. 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 includesBehavior: Symbol). self assert: function arguments first pattern object = #a:b:c:. self assert: function arguments first pattern name = nil. self assert: function arguments first pattern alias = nil. 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 includesBehavior: Symbol). self assert: function arguments first pattern object = #'abc'. self assert: function arguments first pattern name = nil. self assert: function arguments first pattern alias = nil. 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 includesBehavior: Symbol). self assert: function arguments first pattern object = #++. self assert: function arguments first pattern name = nil. self assert: function arguments first pattern alias = nil.! ! !PMParserTest methodsFor: 'testing-pattern' stamp: 'lr 2/9/2007 08:50'! 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 includesBehavior: String). self assert: function arguments first pattern object = 'abc'. self assert: function arguments first pattern name = nil. self assert: function arguments first pattern alias = nil. function := self parse: 'a>>foo: ''abc'' as b'. 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 includesBehavior: String). self assert: function arguments first pattern object = 'abc'. self assert: function arguments first pattern name = nil. self assert: function arguments first pattern alias = 'b'.! ! !PMParserTest methodsFor: 'testing-pattern' stamp: 'lr 1/11/2004 15:27'! testOpenList function := self parse: 'a>>foo: {x as head|xs as tail} as list'. 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 assert: function arguments first pattern isEmpty = false. self assert: function arguments first pattern name = nil. self assert: function arguments first pattern alias = 'list'. 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 first alias = 'head'. 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'. self assert: function arguments first pattern tail alias = 'tail'. 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 assert: function arguments first pattern isEmpty = false. self assert: function arguments first pattern name = nil. self assert: function arguments first pattern alias = nil. 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 first alias = nil. 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'. self assert: function arguments first pattern tail items first alias = nil.! ! !PMParserTest methodsFor: 'testing-errors' 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 1/11/2004 15:28'! testReceiver function := self parse: 'a as b>>foo'. self assert: function receiver class == PMVariablePattern. self assert: function receiver parent == function. self assert: function receiver name = 'a'. self assert: function receiver alias = 'b'. function := self parse: '0 as b>>foo'. self assert: function receiver class == PMObjectPattern. self assert: function receiver parent == function. self assert: function receiver object = 0. self assert: function receiver alias = 'b'. function := self parse: '{} as b>>foo'. self assert: function receiver class == PMListPattern. self assert: function receiver parent == function. self assert: function receiver isEmpty = true. self assert: function receiver alias = 'b'. ! ! !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-errors' 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-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-pattern' stamp: 'lr 1/11/2004 15:29'! 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'. self assert: function arguments first pattern alias = nil. function := self parse: 'a>>foo: b as c'. 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'. self assert: function arguments first pattern alias = 'c'. ! ! !PMParserTest methodsFor: 'testing' stamp: 'lr 1/11/2004 15:34'! testWhitespace function := self parse: 'a as b>>foo: c if: [d] e'. self assert: function receiver class == PMVariablePattern. self assert: function receiver name = 'a'. self assert: function receiver alias = 'b'. 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 = 'c'. self assert: function arguments first pattern alias = nil. self assert: function condition class == PMExpression. self assert: function condition source = 'd'. self assert: function body class == PMExpression. self assert: function body source = ' e'. function := self parse: 'a as b>> foo: c if: [ d ] e'. self assert: function receiver class == PMVariablePattern. self assert: function receiver name = 'a'. self assert: function receiver alias = 'b'. 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 = 'c'. self assert: function arguments first pattern alias = nil. self assert: function condition class == PMExpression. self assert: function condition source = ' d '. self assert: function body class == PMExpression. self assert: function body source = ' e'. function := self parse: 'a as b >> foo: c if: [ d ] e'. self assert: function receiver class == PMVariablePattern. self assert: function receiver name = 'a'. self assert: function receiver alias = 'b'. 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 = 'c'. self assert: function arguments first pattern alias = nil. self assert: function condition class == PMExpression. self assert: function condition source = ' d '. self assert: function body class == PMExpression. self assert: function body source = ' e'.! ! PMFunctionalTest subclass: #PMSymbolicTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Tests'! !PMSymbolicTest methodsFor: 'testing-deriv' stamp: 'lr 1/10/2004 20:35'! testDerivChain self assert: (#(f #(g x)) symDeriv: #x) = #(* (#'f''' (g x)) (#'g''' x))! ! !PMSymbolicTest methodsFor: 'testing-deriv' stamp: 'lr 1/10/2004 20:33'! testDerivChainCos self assert: (#(cos x) symDeriv: #x) = #(- 0 (sin x)). self assert: (#(cos #(* x x)) symDeriv: #x) = #(* (- 0 (sin (* x x))) (+ (* 1 x) (* x 1))). ! ! !PMSymbolicTest methodsFor: 'testing-deriv' stamp: 'lr 1/10/2004 20:32'! testDerivChainExp self assert: (#(exp x) symDeriv: #x) = #(exp x). self assert: (#(exp #(* x x)) symDeriv: #x) = #(* (exp (* x x)) (+ (* 1 x) (* x 1))).! ! !PMSymbolicTest methodsFor: 'testing-deriv' stamp: 'lr 1/10/2004 20:32'! testDerivChainLn self assert: (#(ln x) symDeriv: #x) = #(/ 1 x). self assert: (#(ln #(* x x)) symDeriv: #x) = #(* (/ 1 (* x x)) (+ (* 1 x) (* x 1))). ! ! !PMSymbolicTest methodsFor: 'testing-deriv' stamp: 'lr 2/9/2004 15:30'! testDerivChainRaisedTo " self assert: (#(raisedTo: (* a x) (+ b c)) symDeriv: #x) symSimp"! ! !PMSymbolicTest methodsFor: 'testing-deriv' stamp: 'lr 1/10/2004 20:33'! testDerivChainSin self assert: (#(sin x) symDeriv: #x) = #(cos x). self assert: (#(sin #(* x x)) symDeriv: #x) = #(* (cos (* x x)) (+ (* 1 x) (* x 1))). ! ! !PMSymbolicTest methodsFor: 'testing-deriv' stamp: 'lr 1/10/2004 20:32'! testDerivChainSqrt self assert: (#(sqrt x) symDeriv: #x) = #(/ 1 (* 2 (sqrt x))). self assert: (#(sqrt #(* x x)) symDeriv: #x) = #(* (/ 1 (* 2 (sqrt (* x x)))) (+ (* 1 x) (* x 1))).! ! !PMSymbolicTest methodsFor: 'testing-deriv' stamp: 'lr 1/10/2004 20:39'! testDerivDiv self assert: (#(/ (#f x) (#g x)) symDeriv: #x) = #(/ (- (* (#'f''' x) (g x)) (* (f x) (#'g''' x))) (* (g x) (g x))). self assert: (#(/ x (/ 2 3)) symDeriv: #x) = #(/ (- (* 1 (/ 2 3)) (* x (/ (- (* 0 3) (* 2 0)) (* 3 3)))) (* (/ 2 3) (/ 2 3))). self assert: (#(/ 1 (/ x 3)) symDeriv: #x) = #(/ (- (* 0 (/ x 3)) (* 1 (/ (- (* 1 3) (* x 0)) (* 3 3)))) (* (/ x 3) (/ x 3))). self assert: (#(/ 1 (/ 2 x)) symDeriv: #x) = #(/ (- (* 0 (/ 2 x)) (* 1 (/ (- (* 0 x) (* 2 1)) (* x x)))) (* (/ 2 x) (/ 2 x))). self assert: (#(/ (/ x 2) 3) symDeriv: #x) = #(/ (- (* (/ (- (* 1 2) (* x 0)) (* 2 2)) 3) (* (/ x 2) 0)) (* 3 3)). self assert: (#(/ (/ 1 x) 3) symDeriv: #x) = #(/ (- (* (/ (- (* 0 x) (* 1 1)) (* x x)) 3) (* #(/ 1 x) 0)) (* 3 3)). self assert: (#(/ (/ 1 2) x) symDeriv: #x) = #(/ (- (* (/ (- (* 0 2) (* 1 0)) (* 2 2)) x) (* (/ 1 2) 1)) (* x x)).! ! !PMSymbolicTest methodsFor: 'testing-deriv' stamp: 'lr 1/10/2004 20:37'! testDerivMul self assert: (#(* (f x) (g x)) symDeriv: #x) = #(+ #(* (#'f''' x) (#g x)) #(* (#f x) (#'g''' x))). self assert: (#(* x (* 2 3)) symDeriv: #x) = #(+ (* 1 (* 2 3)) (* x (+ (* 0 3) (* 2 0)))). self assert: (#(* 1 (* x 3)) symDeriv: #x) = #(+ (* 0 (* x 3)) (* 1 (+ (* 1 3) (* x 0)))). self assert: (#(* 1 (* 2 x)) symDeriv: #x) = #(+ (* 0 (* 2 x)) (* 1 (+ (* 0 x) (* 2 1)))). self assert: (#(* (* x 2) 3) symDeriv: #x) = #(+ (* (+ (* 1 2) (* x 0)) 3) (* (* x 2) 0)). self assert: (#(* (* 1 x) 3) symDeriv: #x) = #(+ (* (+ (* 0 x) (* 1 1)) 3) (* (* 1 x) 0)). self assert: (#(* (* 1 2) x) symDeriv: #x) = #(+ (* (+ (* 0 2) (* 1 0)) x) (* (* 1 2) 1)).! ! !PMSymbolicTest methodsFor: 'testing-deriv' stamp: 'lr 1/10/2004 18:48'! testDerivNum self assert: (1 symDeriv: #x) = 0. self assert: (2 symDeriv: #x) = 0. self assert: (3 symDeriv: #x) = 0.! ! !PMSymbolicTest methodsFor: 'testing-deriv' stamp: 'lr 1/18/2004 14:15'! testDerivRaisedTo self assert: (#(raisedTo: x 1) symDeriv: #x) symSimp = 1. self assert: (#(raisedTo: x 2) symDeriv: #x) symSimp = #(* 2 x). self assert: (#(raisedTo: x 3) symDeriv: #x) symSimp = #(* 3 (raisedTo: x 2)). self assert: (#(raisedTo: x 4) symDeriv: #x) symSimp = #(* 4 (raisedTo: x 3)).! ! !PMSymbolicTest methodsFor: 'testing-deriv' stamp: 'lr 1/18/2004 14:18'! testDerivRaisedTo1 self assert: (#(raisedTo: 2 x) symDeriv: #x) = #(* (ln 2) (raisedTo: 2 x)). self assert: (#(raisedTo: 3 x) symDeriv: #x) = #(* (ln 3) (raisedTo: 3 x)). ! ! !PMSymbolicTest methodsFor: 'testing-deriv' stamp: 'lr 1/10/2004 20:36'! testDerivSub self assert: (#(- (f x) (g x)) symDeriv: #x) = #(- (#'f''' x) (#'g''' x)). self assert: (#(- x (- 2 3)) symDeriv: #x) = #(- 1 (- 0 0)). self assert: (#(- 1 (- x 3)) symDeriv: #x) = #(- 0 (- 1 0)). self assert: (#(- 1 (- 2 x)) symDeriv: #x) = #(- 0 (- 0 1)). self assert: (#(- (- x 2) 3) symDeriv: #x) = #(- (- 1 0) 0). self assert: (#(- (- 1 x) 3) symDeriv: #x) = #(- (- 0 1) 0). self assert: (#(- (- 1 2) x) symDeriv: #x) = #(- (- 0 0) 1).! ! !PMSymbolicTest methodsFor: 'testing-deriv' stamp: 'lr 1/10/2004 20:36'! testDerivSum self assert: (#(+ (f x) (g x)) symDeriv: #x) = #(+ (#'f''' x) (#'g''' x)). self assert: (#(+ x (+ 2 3)) symDeriv: #x) = #(+ 1 (+ 0 0)). self assert: (#(+ 1 (+ x 3)) symDeriv: #x) = #(+ 0 (+ 1 0)). self assert: (#(+ 1 (+ 2 x)) symDeriv: #x) = #(+ 0 (+ 0 1)). self assert: (#(+ (+ x 2) 3) symDeriv: #x) = #(+ (+ 1 0) 0). self assert: (#(+ (+ 1 x) 3) symDeriv: #x) = #(+ (+ 0 1) 0). self assert: (#(+ (+ 1 2) x) symDeriv: #x) = #(+ (+ 0 0) 1).! ! !PMSymbolicTest methodsFor: 'testing-deriv' stamp: 'lr 1/10/2004 18:33'! testDerivSym self assert: (#x symDeriv: #x) = 1. self assert: (#y symDeriv: #x) = 0.! ! !PMSymbolicTest methodsFor: 'testing-eval' stamp: 'lr 1/18/2004 10:42'! testEvalBinary self assert: #(+ 1 2) symEval = 3. self assert: #(+ 1 (* 2 3)) symEval = 7. self assert: #(+ (* 1 2) 3) symEval = 5. self assert: #(- 1 2) symEval = -1. self assert: #(- 1 (/ 6 3)) symEval = -1. self assert: #(- (/ 4 2) 3) symEval = -1. self assert: #(raisedTo: 0 0) symEval = 1. self assert: #(raisedTo: 1 1) symEval = 1. self assert: #(raisedTo: 2 3) symEval = 8.! ! !PMSymbolicTest methodsFor: 'testing-eval' stamp: 'lr 1/10/2004 18:55'! testEvalNumber self assert: 1 symEval = 1. self assert: 2 symEval = 2.! ! !PMSymbolicTest methodsFor: 'testing-eval' stamp: 'lr 1/10/2004 18:53'! testEvalSymbol self assert: #a symEval isNil. self assert: #Object symEval = Object.! ! !PMSymbolicTest methodsFor: 'testing-eval' stamp: 'lr 1/10/2004 18:52'! testEvalUnary self assert: #(factorial 3) symEval = 6. self assert: #(floor 3.14) symEval = 3. self assert: #(cos 0) symEval = 1.0.! ! !PMSymbolicTest methodsFor: 'testing-free' stamp: 'lr 1/18/2004 14:10'! testFree self assert: (#() symIsFree: #x). self assert: (123 symIsFree: #x). self deny: (#x symIsFree: #x).! ! !PMSymbolicTest methodsFor: 'testing-free' stamp: 'lr 1/18/2004 11:13'! testFree1 self deny: (#(x) symIsFree: #x). self deny: (#(a b x) symIsFree: #x). self deny: (#(a (b x)) symIsFree: #x). self deny: (#(a (b (x))) symIsFree: #x).! ! !PMSymbolicTest methodsFor: 'testing-free' stamp: 'lr 1/18/2004 14:09'! testFree2 self assert: (#() symIsFree: #x). self assert: (#(a) symIsFree: #x). self assert: (#(a b c) symIsFree: #x). self assert: (#(a (b c)) symIsFree: #x). self assert: (#(a (b (c))) symIsFree: #x).! ! !PMSymbolicTest methodsFor: 'testing-simp' stamp: 'lr 1/10/2004 20:14'! testSimpAdd self assert: #(+ a (+ 2 3)) symSimp = #(+ a 5). self assert: #(+ 1 (+ a 3)) symSimp = #(+ 1 (+ a 3)). self assert: #(+ 1 (+ 2 a)) symSimp = #(+ 1 (+ 2 a)). self assert: #(+ 1 (+ 2 3)) symSimp = 6. self assert: #(+ (+ 1 2) 3) symSimp = 6.! ! !PMSymbolicTest methodsFor: 'testing-simp' stamp: 'lr 1/10/2004 20:14'! testSimpAdd0 self assert: #(+ a (+ 0 0)) symSimp = #a. self assert: #(+ 0 (+ a 0)) symSimp = #a. self assert: #(+ 0 (+ 0 a)) symSimp = #a. self assert: #(+ (+ a 0) 0) symSimp = #a. self assert: #(+ (+ 0 a) 0) symSimp = #a. self assert: #(+ (+ 0 0) a) symSimp = #a. ! ! !PMSymbolicTest methodsFor: 'testing-simp' stamp: 'lr 1/10/2004 20:14'! testSimpDiv self assert: #(/ a (/ 2 1)) symSimp = #(/ a 2). self assert: #(/ 3 (/ a 1)) symSimp = #(/ 3 a). self assert: #(/ 3 (/ 2 a)) symSimp = #(/ 3 (/ 2 a)). self assert: #(/ 8 (/ 4 2)) symSimp = 4. self assert: #(/ (/ 8 4) 2) symSimp = 1. ! ! !PMSymbolicTest methodsFor: 'testing-simp' stamp: 'lr 1/10/2004 20:14'! testSimpDiv1 self assert: #(/ a (/ 1 1)) symSimp = #a. self assert: #(/ 1 (/ a 1)) symSimp = #(/ 1 a). self assert: #(/ 1 (/ 1 a)) symSimp = #(/ 1 (/ 1 a)). self assert: #(/ (/ a 1) 1) symSimp = #a. self assert: #(/ (/ 1 a) 1) symSimp = #(/ 1 a). self assert: #(/ (/ 1 1) a) symSimp = #(/ 1 a).! ! !PMSymbolicTest methodsFor: 'testing-simp' stamp: 'lr 1/10/2004 20:14'! testSimpMul self assert: #(* a (* 2 3)) symSimp = #(* a 6). self assert: #(* 1 (* a 3)) symSimp = #(* a 3). self assert: #(* 1 (* 2 a)) symSimp = #(* 2 a). self assert: #(* 1 (* 2 3)) symSimp = 6. self assert: #(* (* 1 2) 3) symSimp = 6.! ! !PMSymbolicTest methodsFor: 'testing-simp' stamp: 'lr 1/10/2004 20:14'! testSimpMul0 self assert: #(* a (* 0 0)) symSimp = 0. self assert: #(* 0 (* a 0)) symSimp = 0. self assert: #(* 0 (* 0 a)) symSimp = 0. self assert: #(* (* a 0) 0) symSimp = 0. self assert: #(* (* 0 a) 0) symSimp = 0. self assert: #(* (* 0 0) a) symSimp = 0.! ! !PMSymbolicTest methodsFor: 'testing-simp' stamp: 'lr 1/10/2004 20:14'! testSimpMul1 self assert: #(* a (* 1 1)) symSimp = #a. self assert: #(* 1 (* a 1)) symSimp = #a. self assert: #(* 1 (* 1 a)) symSimp = #a. self assert: #(* (* a 1) 1) symSimp = #a. self assert: #(* (* 1 a) 1) symSimp = #a. self assert: #(* (* 1 1) a) symSimp = #a. ! ! !PMSymbolicTest methodsFor: 'testing-simp' stamp: 'lr 1/18/2004 10:51'! testSimpRaisedTo self assert: #(#raisedTo: a 0) symSimp = 1. self assert: #(#raisedTo: a 1) symSimp = #a. self assert: #(#raisedTo: 0 a) symSimp = 0. self assert: #(#raisedTo: 1 a) symSimp = 1. self assert: #(#raisedTo: 2 3) symSimp = 8. self assert: #(#raisedTo: 3 2) symSimp = 9. ! ! !PMSymbolicTest methodsFor: 'testing-simp' stamp: 'lr 1/18/2004 10:53'! testSimpRaisedTo1 self assert: #(#raisedTo: a (#raisedTo: 1 1)) symSimp = #a. self assert: #(#raisedTo: 1 (#raisedTo: a 1)) symSimp = 1. self assert: #(#raisedTo: 1 (#raisedTo: 1 a)) symSimp = 1. self assert: #(#raisedTo: (#raisedTo: a 1) 1) symSimp = #a. self assert: #(#raisedTo: (#raisedTo: 1 a) 1) symSimp = 1. self assert: #(#raisedTo: (#raisedTo: 1 1) a) symSimp = 1.! ! !PMSymbolicTest methodsFor: 'testing-simp' stamp: 'lr 1/18/2004 10:56'! testSimpRaisedTo2 self assert: #(#raisedTo: a (#raisedTo: 0 0)) symSimp = #a. self assert: #(#raisedTo: 0 (#raisedTo: a 0)) symSimp = 0. self assert: #(#raisedTo: 0 (#raisedTo: 0 a)) symSimp = 0. self assert: #(#raisedTo: (#raisedTo: a 0) 0) symSimp = 1. self assert: #(#raisedTo: (#raisedTo: 0 a) 0) symSimp = 1. self assert: #(#raisedTo: (#raisedTo: 0 0) a) symSimp = 1. ! ! !PMSymbolicTest methodsFor: 'testing-simp' stamp: 'lr 1/10/2004 20:15'! testSimpSub self assert: #(- a (- 2 3)) symSimp = #(- a -1). self assert: #(- 1 (- a 3)) symSimp = #(- 1 (- a 3)). self assert: #(- 1 (- 2 a)) symSimp = #(- 1 (- 2 a)). self assert: #(- 1 (- 2 3)) symSimp = 2. self assert: #(- (- 1 2) 3) symSimp = -4. ! ! !PMSymbolicTest methodsFor: 'testing-simp' stamp: 'lr 1/10/2004 20:15'! testSimpSub0 self assert: #(- a (- 0 0)) symSimp = #a. self assert: #(- 0 (- a 0)) symSimp = #(- 0 a). self assert: #(- 0 (- 0 a)) symSimp = #(- 0 (- 0 a)). self assert: #(- (- a 0) 0) symSimp = #a. self assert: #(- (- 0 a) 0) symSimp = #(- 0 a). self assert: #(- (- 0 0) a) symSimp = #(- 0 a). ! ! !PMSymbolicTest methodsFor: 'testing-subs' stamp: 'lr 1/18/2004 10:57'! testSubsNum self assert: (#(+ 1 (* 2 3)) symSubs: 1 with: 4) = #(+ 4 (* 2 3)). self assert: (#(+ 1 (* 2 3)) symSubs: 2 with: 4) = #(+ 1 (* 4 3)). self assert: (#(+ 1 (* 2 3)) symSubs: 3 with: 4) = #(+ 1 (* 2 4)). self assert: (#(a (b 1)) symSubs: 1 with: 2) = #(a (b 2)).! ! !PMSymbolicTest methodsFor: 'testing-subs' stamp: 'lr 1/18/2004 10:57'! testSubsVar self assert: (#(+ a (* b c)) symSubs: #a with: 1) = #(+ 1 (* b c)). self assert: (#(+ a (* b c)) symSubs: #b with: 1) = #(+ a (* 1 c)). self assert: (#(+ a (* b c)) symSubs: #c with: 1) = #(+ a (* b 1)). self assert: (#(a (b c)) symSubs: #a with: 1) = #(a (b c)). self assert: (#(a (b c)) symSubs: #b with: 1) = #(a (b c)). self assert: (#(a (b c)) symSubs: #c with: 1) = #(a (b 1)).! ! PMFunctionalTest subclass: #PMVisitorTest instanceVariableNames: 'mapping' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Tests'! !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: 'utility' stamp: 'lr 2/9/2007 08:43'! assertSignature: aString self assert: (self parse: aString) asString = aString! ! !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 1/11/2004 16:03'! testAliasPrinting self assertSignature: 'a as u>>foo: true as v'. self assertSignature: 'a as u>>foo: false as v'. self assertSignature: 'a as u>>foo: nil as v'. self assertSignature: 'a as u>>+ b as v'. self assertSignature: 'a as u>>== b as v'. self assertSignature: 'a as u>>// b as v'. self assertSignature: 'a as u>>foo: aPoint as v'. self assertSignature: 'a as u>>foo: anInteger as v'. self assertSignature: 'a as u>>foo: b as v'. self assertSignature: 'a as u>>foo: b as v bar: c as v1'. self assertSignature: 'a as u>>foo: b as v bar: c as v1 zork: d as v2'. self assertSignature: 'a as u>>foo: {} as v'. self assertSignature: 'a as u>>foo: {x as v} as v'. self assertSignature: 'a as u>>foo: {x as v. y as v1} as v2'. self assertSignature: 'a as u>>foo: {x as v. y as v2. z as v3} as v4'. self assertSignature: 'a as u>>foo: {x as v|xs as v1} as v2'. self assertSignature: 'a as u>>foo: {x as v. y as v1|ys as v2} as v3'. self assertSignature: 'a as u>>foo: {x as v. y as v1. z as v2|zs as v3} as v4'. self assertSignature: 'a as u>>foo: {x as v|{y as v1} as v2} as v3'. self assertSignature: 'a as u>>foo: {x as v|{y as v1|ya as v2} as v3} as v4'. self assertSignature: 'a as u>>foo: {x as v|{y as v1|{z as v2|zs as v3} as v4} as v5} as v6'. self assertSignature: 'a as u>>foo: {1 as v|x as v1} as v2'. self assertSignature: 'a as u>>foo: {1 as v. 2 as v1|x as v2} as v3'. self assertSignature: 'a as u>>foo: {#a as v|x as v1} as v3'. self assertSignature: 'a as u>>foo: {#a as v. #b as v1|x as v2} as v3'. self assertSignature: 'a as u>>foo: 123 as v'. self assertSignature: 'a as u>>foo: 123.456 as v'. self assertSignature: 'a as u>>foo: $a as v'. self assertSignature: 'a as u>>foo: ''abc'' as v'. self assertSignature: 'a as u>>foo: #abc:abc: as v'. self assertSignature: 'a as u>>foo'. self assertSignature: '0 as u>>foo'. self assertSignature: '{} as u>>foo'. self assertSignature: 'a as u>>foo: #''a b c'' as v'. self assertSignature: 'a as u>>foo: #abc as v'. self assertSignature: 'a as u>>foo: #+ as v'. self assertSignature: 'a as u>>foo: #abc: as v'. self assertSignature: 'a as u>>foo: #abc:abc: as v'. self assertSignature: 'a as u>>foo: [ :b | b ] as v'. self assertSignature: 'a as u>>foo: [ :b | b < 0 ] as v'. self assertSignature: 'a as u>>foo: [ :b | b asInteger < 0 ] as v'.! ! !PMVisitorTest methodsFor: 'testing-printing' stamp: 'lr 12/4/2003 21:37'! testBodyPrinting self assertFunction: 'a>>foo ^self foo'. self assertFunction: 'a>>foo ^self foo'.! ! !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-alias' stamp: 'lr 1/11/2004 16:56'! testEqualAlias self mappingOf: 'x>>foo: y as x'. self assert: mapping size = 1. self assert: (mapping at: 'x') = #( 'self' 't1' ). self mappingOf: 'x>>foo: y as x bar: z as x'. self assert: mapping size = 1. self assert: (mapping at: 'x') = #( 'self' 't1' 't2' ). self mappingOf: 'x>>foo: x bar: x as y zork: x as y'. self assert: mapping size = 2. self assert: (mapping at: 'x') = #( 'self' 't1' ). self assert: (mapping at: 'y') = #( 't2' 't3' ). self mappingOf: 'aSymbol1 as aSymbol>>foo: aSymbol2 as aSymbol'. self assert: mapping size = 1. self assert: (mapping at: 'aSymbol') = #( 'self' 't1' ). self mappingOf: '[ :x | x ]>>foo: [ :y | y not ] as x'. self assert: mapping size = 1. self assert: (mapping at: 'x') = #( 'self' 't1' ). self mappingOf: '{a as x}>>foo: {b as x.c as x}'. self assert: mapping size = 1. self assert: (mapping at: 'x') = #( 'self at: 1' 't1 at: 1' 't1 at: 2' ). self mappingOf: '{a as x|b as xs}>>foo: {c as x|d as 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: '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: 'testing-alias' stamp: 'lr 1/11/2004 16:43'! testListAlias self mappingOf: '0>>foo: {} as l1'. self assert: mapping size = 1. self assert: (mapping at: 'l1') = 't1'. self mappingOf: '0>>foo: {x as l1} as l2'. self assert: mapping size = 2. self assert: (mapping at: 'l1') = 't1 at: 1'. self assert: (mapping at: 'l2') = 't1'. self mappingOf: '0>>foo: {x as l1. y as l2} as l3'. self assert: mapping size = 3. self assert: (mapping at: 'l1') = 't1 at: 1'. self assert: (mapping at: 'l2') = 't1 at: 2'. self assert: (mapping at: 'l3') = 't1'. self mappingOf: '0>>foo: {x as l1. y as l2. z as l3} as l4'. self assert: mapping size = 4. self assert: (mapping at: 'l1') = 't1 at: 1'. self assert: (mapping at: 'l2') = 't1 at: 2'. self assert: (mapping at: 'l3') = 't1 at: 3'. self assert: (mapping at: 'l4') = 't1'. self mappingOf: '0>>foo: {true as l1. y as l2. false as l3} as l4'. self assert: mapping size = 4. self assert: (mapping at: 'l1') = 't1 at: 1'. self assert: (mapping at: 'l2') = 't1 at: 2'. self assert: (mapping at: 'l3') = 't1 at: 3'. self assert: (mapping at: 'l4') = 't1'.! ! !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-alias' stamp: 'lr 1/11/2004 16:50'! testMultipleAlias self mappingOf: 'a as a1>>foo: b as a2 bar: c as a3'. self assert: mapping size = 3. self assert: (mapping at: 'a1') = 'self'. self assert: (mapping at: 'a2') = 't1'. self assert: (mapping at: 'a3') = 't2'. self mappingOf: '{a as a1. b as a2.c as a3} as a4>>foo: {d as a5. e as a6. f as a7} as a8 bar: {g as a9|i as a10} as a11'. self assert: mapping size = 11. self assert: (mapping at: 'a1') = 'self at: 1'. self assert: (mapping at: 'a2') = 'self at: 2'. self assert: (mapping at: 'a3') = 'self at: 3'. self assert: (mapping at: 'a4') = 'self'. self assert: (mapping at: 'a5') = 't1 at: 1'. self assert: (mapping at: 'a6') = 't1 at: 2'. self assert: (mapping at: 'a7') = 't1 at: 3'. self assert: (mapping at: 'a8') = 't1'. self assert: (mapping at: 'a9') = 't2 at: 1'. self assert: (mapping at: 'a10') = 't2 allButFirst: 1'. self assert: (mapping at: 'a11') = 't2'. self mappingOf: 'a as a1>>foo: {b as a2 | [ :c | c size > 3 ] as a3} bar: 0 as a4 zork: d as a5'. self assert: mapping size = 5. self assert: (mapping at: 'a1') = 'self'. self assert: (mapping at: 'a2') = 't1 at: 1'. self assert: (mapping at: 'a3') = 't1 allButFirst: 1'. self assert: (mapping at: 'a4') = 't2'. self assert: (mapping at: 'a5') = 't3'.! ! !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-alias' stamp: 'lr 1/11/2004 16:42'! testNestedListAlias self mappingOf: '0>>foo: {x as l1|{} as l2} as l3'. self assert: mapping size = 3. self assert: (mapping at: 'l1') = 't1 at: 1'. self assert: (mapping at: 'l2') = 't1 allButFirst: 1'. self assert: (mapping at: 'l3') = 't1'. self mappingOf: '0>>foo: {x as l1|{y as l2} as l3} as l4'. self assert: mapping size = 4. self assert: (mapping at: 'l1') = 't1 at: 1'. self assert: (mapping at: 'l2') = '(t1 allButFirst: 1) at: 1'. self assert: (mapping at: 'l3') = 't1 allButFirst: 1'. self assert: (mapping at: 'l4') = 't1'. self mappingOf: '0>>foo: {x as l1|{y as l2|ys as l3} as l4} as l5'. self assert: mapping size = 5. self assert: (mapping at: 'l1') = 't1 at: 1'. self assert: (mapping at: 'l2') = '(t1 allButFirst: 1) at: 1'. self assert: (mapping at: 'l3') = '(t1 allButFirst: 1) allButFirst: 1'. self assert: (mapping at: 'l4') = 't1 allButFirst: 1'. self assert: (mapping at: 'l5') = 't1'. ! ! !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-alias' stamp: 'lr 1/11/2004 16:46'! testObjectAlias self mappingOf: '0>>foo: true as o'. self assert: mapping size = 1. self assert: (mapping at: 'o') = 't1'. self mappingOf: '0>>foo: 123 as o'. self assert: mapping size = 1. self assert: (mapping at: 'o') = 't1'. self mappingOf: '0>>foo: a as o'. self assert: mapping size = 1. self assert: (mapping at: 'o') = 't1'. self mappingOf: '0>>foo: [ :a | a isFoo ] as o'. self assert: mapping size = 1. self assert: (mapping at: 'o') = 't1'. self mappingOf: '0>>foo: anAssociation as o'. self assert: mapping size = 1. self assert: (mapping at: 'o') = 't1'.! ! !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-alias' stamp: 'lr 1/11/2004 16:44'! testOpenListAlias self mappingOf: '0>>foo: {x as l1|xs as l2} as l3'. self assert: mapping size = 3. self assert: (mapping at: 'l1') = 't1 at: 1'. self assert: (mapping at: 'l2') = 't1 allButFirst: 1'. self assert: (mapping at: 'l3') = 't1'. self mappingOf: '0>>foo: {x as l1. y as l2|xs as l3} as l4'. self assert: mapping size = 4. self assert: (mapping at: 'l1') = 't1 at: 1'. self assert: (mapping at: 'l2') = 't1 at: 2'. self assert: (mapping at: 'l3') = 't1 allButFirst: 2'. self assert: (mapping at: 'l4') = 't1'. self mappingOf: '0>>foo: {x as l1. y as l2. z as l3|xs as l4} as l5'. self assert: mapping size = 5. self assert: (mapping at: 'l1') = 't1 at: 1'. self assert: (mapping at: 'l2') = 't1 at: 2'. self assert: (mapping at: 'l3') = 't1 at: 3'. self assert: (mapping at: 'l4') = 't1 allButFirst: 3'. self assert: (mapping at: 'l5') = 't1'. self mappingOf: '0>>foo: {x as l1|nil as l2} as l3'. self assert: mapping size = 3. self assert: (mapping at: 'l1') = 't1 at: 1'. self assert: (mapping at: 'l2') = 't1 allButFirst: 1'. self assert: (mapping at: 'l3') = '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-alias' stamp: 'lr 1/11/2004 16:34'! testReceiverAlias self mappingOf: 'a as r>>foo'. self assert: mapping size = 1. self assert: (mapping at: 'r') = 'self'. self mappingOf: '[ :a | a isFoo ] as r>>foo'. self assert: mapping size = 1. self assert: (mapping at: 'r') = 'self'. self mappingOf: 'anAssociation as r>>foo'. self assert: mapping size = 1. self assert: (mapping at: 'r') = 'self'. self mappingOf: '{x as r1|xs as r2} as r3>>foo'. self assert: mapping size = 3. self assert: (mapping at: 'r1') = 'self at: 1'. self assert: (mapping at: 'r2') = 'self allButFirst: 1'. self assert: (mapping at: 'r3') = 'self'. ! ! !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: 'testing-printing' stamp: 'lr 2/9/2007 08:44'! 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 ]'.! ! !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/11/2004 17:12'! 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/11/2004 17:12'! 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/11/2004 17:12'! 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-Examples-Functional' stamp: 'lr 1/11/2004 17:12'! 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/11/2004 17:12'! 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})! ! !Object methodsFor: '*Pattern-Symbolic-Functional' stamp: 'lr 2/9/2007 09:14'! symDeriv: t1 "anNumber>>symDeriv: aSymbol ^0" "aSymbol>>symDeriv: aSymbol ^1" "aSymbol>>symDeriv: aSymbol as aSecondSymbol ^0" "{#+. f. g}>>symDeriv: aSymbol ^{#+. f symDeriv: aSymbol. g symDeriv: aSymbol}" "{#-. f. g}>>symDeriv: aSymbol ^{#-. f symDeriv: aSymbol. g symDeriv: aSymbol}" "{#*. f. g}>>symDeriv: aSymbol ^{#+. {#*. f symDeriv: aSymbol. g}. {#*. f. g symDeriv: aSymbol} }" "{#/. f. g}>>symDeriv: aSymbol ^{#/. {#-. {#*. f symDeriv: aSymbol. g}. {#*. f. g symDeriv: aSymbol} }. {#*. g. g} }" "{#sin. aSymbol}>>symDeriv: aSymbol ^{#cos. aSymbol}" "{#cos. aSymbol}>>symDeriv: aSymbol ^{#-. 0. {#sin. aSymbol} }" "{#sqrt. aSymbol}>>symDeriv: aSymbol ^{#/. 1. {#*. 2. {#sqrt. aSymbol} } }" "{#exp. aSymbol}>>symDeriv: aSymbol ^{#exp. aSymbol}" "{#ln. aSymbol}>>symDeriv: aSymbol ^{#/. 1. aSymbol}" "{#raisedTo:. aSymbol. g}>>symDeriv: aSymbol if: [ g symIsFree: aSymbol ] ^{#*. g. {#raisedTo:. aSymbol. {#-. g. 1} } }" "{#raisedTo:. g. aSymbol}>>symDeriv: aSymbol if: [ g symIsFree: aSymbol ] ^{#*. {#ln. g}. {#raisedTo:. g. aSymbol} }" "{aSymbol as f. aSymbol}>>symDeriv: aSymbol ^{ (f , '''') asSymbol. aSymbol }" "{aSymbol as f. g}>>symDeriv: aSymbol ^{#*. ({f. aSymbol} symDeriv: aSymbol) symSubs: aSymbol with: g. g symDeriv: aSymbol }" ((self isKindOf: Number) and: [(t1 isKindOf: Symbol)]) ifTrue: [^0]. (((self isKindOf: Symbol) and: [(t1 isKindOf: Symbol)]) and: [(self = t1)]) ifTrue: [^1]. ((self isKindOf: Symbol) and: [(t1 isKindOf: Symbol)]) ifTrue: [^0]. ((((self isKindOf: SequenceableCollection) and: [(self size == 3)]) and: [((self at: 1) == #+)]) and: [(t1 isKindOf: Symbol)]) ifTrue: [^{ #+. (self at: 2) symDeriv: t1. (self at: 3) symDeriv: t1}]. ((((self isKindOf: SequenceableCollection) and: [(self size == 3)]) and: [((self at: 1) == #-)]) and: [(t1 isKindOf: Symbol)]) ifTrue: [^{ #-. (self at: 2) symDeriv: t1. (self at: 3) symDeriv: t1}]. ((((self isKindOf: SequenceableCollection) and: [(self size == 3)]) and: [((self at: 1) == #*)]) and: [(t1 isKindOf: Symbol)]) ifTrue: [^{ #+. { #*. (self at: 2) symDeriv: t1. self at: 3}. { #*. self at: 2. (self at: 3) symDeriv: t1}}]. ((((self isKindOf: SequenceableCollection) and: [(self size == 3)]) and: [((self at: 1) == #/)]) and: [(t1 isKindOf: Symbol)]) ifTrue: [^{ #/. { #-. { #*. (self at: 2) symDeriv: t1. self at: 3}. { #*. self at: 2. (self at: 3) symDeriv: t1}}. { #*. self at: 3. self at: 3}}]. ((((((self isKindOf: SequenceableCollection) and: [(self size == 2)]) and: [((self at: 1) == #sin)]) and: [((self at: 2) isKindOf: Symbol)]) and: [(t1 isKindOf: Symbol)]) and: [((self at: 2) = t1)]) ifTrue: [^{ #cos. self at: 2}]. ((((((self isKindOf: SequenceableCollection) and: [(self size == 2)]) and: [((self at: 1) == #cos)]) and: [((self at: 2) isKindOf: Symbol)]) and: [(t1 isKindOf: Symbol)]) and: [((self at: 2) = t1)]) ifTrue: [^{ #-. 0. { #sin. self at: 2}}]. ((((((self isKindOf: SequenceableCollection) and: [(self size == 2)]) and: [((self at: 1) == #sqrt)]) and: [((self at: 2) isKindOf: Symbol)]) and: [(t1 isKindOf: Symbol)]) and: [((self at: 2) = t1)]) ifTrue: [^{ #/. 1. { #*. 2. { #sqrt. self at: 2}}}]. ((((((self isKindOf: SequenceableCollection) and: [(self size == 2)]) and: [((self at: 1) == #exp)]) and: [((self at: 2) isKindOf: Symbol)]) and: [(t1 isKindOf: Symbol)]) and: [((self at: 2) = t1)]) ifTrue: [^{ #exp. self at: 2}]. ((((((self isKindOf: SequenceableCollection) and: [(self size == 2)]) and: [((self at: 1) == #ln)]) and: [((self at: 2) isKindOf: Symbol)]) and: [(t1 isKindOf: Symbol)]) and: [((self at: 2) = t1)]) ifTrue: [^{ #/. 1. self at: 2}]. (((((((self isKindOf: SequenceableCollection) and: [(self size == 3)]) and: [((self at: 1) == #raisedTo:)]) and: [((self at: 2) isKindOf: Symbol)]) and: [(t1 isKindOf: Symbol)]) and: [((self at: 2) = t1)]) and: [((self at: 3) symIsFree: (self at: 2))]) ifTrue: [^{ #*. self at: 3. { #raisedTo:. self at: 2. { #-. self at: 3. 1}}}]. (((((((self isKindOf: SequenceableCollection) and: [(self size == 3)]) and: [((self at: 1) == #raisedTo:)]) and: [((self at: 3) isKindOf: Symbol)]) and: [(t1 isKindOf: Symbol)]) and: [((self at: 3) = t1)]) and: [((self at: 2) symIsFree: (self at: 3))]) ifTrue: [^{ #*. { #ln. self at: 2}. { #raisedTo:. self at: 2. self at: 3}}]. ((((((self isKindOf: SequenceableCollection) and: [(self size == 2)]) and: [((self at: 1) isKindOf: Symbol)]) and: [((self at: 2) isKindOf: Symbol)]) and: [(t1 isKindOf: Symbol)]) and: [((self at: 2) = t1)]) ifTrue: [^{ ((self at: 1) , '''') asSymbol. self at: 2}]. ((((self isKindOf: SequenceableCollection) and: [(self size == 2)]) and: [((self at: 1) isKindOf: Symbol)]) and: [(t1 isKindOf: Symbol)]) ifTrue: [^{ #*. ({ self at: 1. t1} symDeriv: t1) symSubs: t1 with: (self at: 2). (self at: 2) symDeriv: t1}]. ^self doesNotUnderstand: (Message selector: #symDeriv: arguments: { t1}) ! ! !Object methodsFor: '*Pattern-Symbolic-Functional' stamp: 'lr 2/9/2007 08:56'! symEval "aSymbol>>symEval ^Smalltalk at: aSymbol ifAbsent: [ nil ]" "anNumber>>symEval ^anNumber" "{aSymbol. a}>>symEval ^a symEval perform: aSymbol" "{aSymbol. a. b}>>symEval ^a symEval perform: aSymbol with: b symEval" (self isKindOf: Symbol) ifTrue: [^ Smalltalk at: self ifAbsent: [nil]]. (self isKindOf: Number) ifTrue: [^ self]. (((self isKindOf: SequenceableCollection) and: [(self size = 2)]) and: [((self at: 1) isKindOf: Symbol)]) ifTrue: [^ (self at: 2) symEval perform: (self at: 1)]. (((self isKindOf: SequenceableCollection) and: [(self size = 3)]) and: [((self at: 1) isKindOf: Symbol)]) ifTrue: [^ (self at: 2) symEval perform: (self at: 1) with: (self at: 3) symEval]. ^ self doesNotUnderstand: (Message selector: #symEval arguments: { })! ! !Object methodsFor: '*Pattern-Symbolic-Functional' stamp: 'lr 2/9/2007 09:15'! symIsFree: t1 "aSymbol>>symIsFree: aSymbol ^false" "aSymbol1>>symIsFree: aSymbol2 ^true" "aNumber>>symIsFree: aSymbol ^true" "{}>>symIsFree: aSymbol ^true" "{x|xs}>>symIsFree: aSymbol ^(x symIsFree: aSymbol) and: [ xs symIsFree: aSymbol ]" (((self isKindOf: Symbol) and: [(t1 isKindOf: Symbol)]) and: [(self = t1)]) ifTrue: [^false]. ((self isKindOf: Symbol) and: [(t1 isKindOf: Symbol)]) ifTrue: [^true]. ((self isKindOf: Number) and: [(t1 isKindOf: Symbol)]) ifTrue: [^true]. (((self isKindOf: SequenceableCollection) and: [(self size == 0)]) and: [(t1 isKindOf: Symbol)]) ifTrue: [^true]. (((self isKindOf: SequenceableCollection) and: [(self size >= 1)]) and: [(t1 isKindOf: Symbol)]) ifTrue: [^((self at: 1) symIsFree: t1) and: [(self allButFirst: 1) symIsFree: t1]]. ^self doesNotUnderstand: (Message selector: #symIsFree: arguments: { t1}) ! ! !Object methodsFor: '*Pattern-Symbolic-Functional' stamp: 'lr 2/9/2007 08:56'! symSimp "{#+. a. 0}>>symSimp ^a symSimp" "{#+. 0. b}>>symSimp ^b symSimp" "{#-. a. 0}>>symSimp ^a symSimp" "{#*. a. b}>>symSimp if: [ a = 0 or: [ b = 0 ] ] ^0" "{#*. a. 1}>>symSimp ^a symSimp" "{#*. 1. b}>>symSimp ^b symSimp" "{#/. a. 1}>>symSimp ^a symSimp" "{#raisedTo:. a. 0}>>symSimp ^1" "{#raisedTo:. a. 1}>>symSimp ^a symSimp" "{#raisedTo:. 0. a}>>symSimp ^0" "{#raisedTo:. 1. a}>>symSimp ^1" "{aSymbol. aNumber}>>symSimp ^self symEval" "{aSymbol. aNumber as n1. aNumber as n2}>>symSimp ^self symEval" "{aSymbol. a}>>symSimp ^{aSymbol. a symSimp}" "{aSymbol. a. b}>>symSimp | simplified | simplified := {aSymbol. a symSimp. b symSimp}. ^self = simplified ifFalse: [ simplified symSimp ] ifTrue: [ simplified ]" "anObject>>symSimp ^anObject" ((((self isKindOf: SequenceableCollection) and: [(self size = 3)]) and: [((self at: 1) = #+)]) and: [((self at: 3) = 0)]) ifTrue: [^ (self at: 2) symSimp]. ((((self isKindOf: SequenceableCollection) and: [(self size = 3)]) and: [((self at: 1) = #+)]) and: [((self at: 2) = 0)]) ifTrue: [^ (self at: 3) symSimp]. ((((self isKindOf: SequenceableCollection) and: [(self size = 3)]) and: [((self at: 1) = #-)]) and: [((self at: 3) = 0)]) ifTrue: [^ (self at: 2) symSimp]. ((((self isKindOf: SequenceableCollection) and: [(self size = 3)]) and: [((self at: 1) = #*)]) and: [((self at: 2) = 0 or: [(self at: 3) = 0])]) ifTrue: [^ 0]. ((((self isKindOf: SequenceableCollection) and: [(self size = 3)]) and: [((self at: 1) = #*)]) and: [((self at: 3) = 1)]) ifTrue: [^ (self at: 2) symSimp]. ((((self isKindOf: SequenceableCollection) and: [(self size = 3)]) and: [((self at: 1) = #*)]) and: [((self at: 2) = 1)]) ifTrue: [^ (self at: 3) symSimp]. ((((self isKindOf: SequenceableCollection) and: [(self size = 3)]) and: [((self at: 1) = #/)]) and: [((self at: 3) = 1)]) ifTrue: [^ (self at: 2) symSimp]. ((((self isKindOf: SequenceableCollection) and: [(self size = 3)]) and: [((self at: 1) = #raisedTo:)]) and: [((self at: 3) = 0)]) ifTrue: [^ 1]. ((((self isKindOf: SequenceableCollection) and: [(self size = 3)]) and: [((self at: 1) = #raisedTo:)]) and: [((self at: 3) = 1)]) ifTrue: [^ (self at: 2) symSimp]. ((((self isKindOf: SequenceableCollection) and: [(self size = 3)]) and: [((self at: 1) = #raisedTo:)]) and: [((self at: 2) = 0)]) ifTrue: [^ 0]. ((((self isKindOf: SequenceableCollection) and: [(self size = 3)]) and: [((self at: 1) = #raisedTo:)]) and: [((self at: 2) = 1)]) ifTrue: [^ 1]. ((((self isKindOf: SequenceableCollection) and: [(self size = 2)]) and: [((self at: 1) isKindOf: Symbol)]) and: [((self at: 2) isKindOf: Number)]) ifTrue: [^ self symEval]. (((((self isKindOf: SequenceableCollection) and: [(self size = 3)]) and: [((self at: 1) isKindOf: Symbol)]) and: [((self at: 2) isKindOf: Number)]) and: [((self at: 3) isKindOf: Number)]) ifTrue: [^ self symEval]. (((self isKindOf: SequenceableCollection) and: [(self size = 2)]) and: [((self at: 1) isKindOf: Symbol)]) ifTrue: [^ { (self at: 1). ((self at: 2) symSimp)}]. (((self isKindOf: SequenceableCollection) and: [(self size = 3)]) and: [((self at: 1) isKindOf: Symbol)]) ifTrue: [| simplified | simplified := { (self at: 1). ((self at: 2) symSimp). ((self at: 3) symSimp)}. ^ self = simplified ifFalse: [simplified symSimp] ifTrue: [simplified]]. true ifTrue: [^ self]. ^ self doesNotUnderstand: (Message selector: #symSimp arguments: { })! ! !Object methodsFor: '*Pattern-Symbolic-Functional' stamp: 'lr 2/9/2007 09:15'! symSubs: t1 with: t2 "{aSymbol. e1}>>symSubs: u with: v ^{aSymbol. e1 symSubs: u with: v} " "{aSymbol. e1. e2}>>symSubs: u with: v ^{aSymbol. e1 symSubs: u with: v. e2 symSubs: u with: v} " "u>>symSubs: u with: v ^v" "x>>symSubs: u with: v ^x" (((self isKindOf: SequenceableCollection) and: [(self size == 2)]) and: [((self at: 1) isKindOf: Symbol)]) ifTrue: [^{ self at: 1. (self at: 2) symSubs: t1 with: t2}]. (((self isKindOf: SequenceableCollection) and: [(self size == 3)]) and: [((self at: 1) isKindOf: Symbol)]) ifTrue: [^{ self at: 1. (self at: 2) symSubs: t1 with: t2. (self at: 3) symSubs: t1 with: t2}]. self = t1 ifTrue: [^t2]. true ifTrue: [^self]. ^self doesNotUnderstand: (Message selector: #symSubs:with: arguments: { t1. t2}) ! ! 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: #PMNode instanceVariableNames: 'parent' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Core'! PMNode subclass: #PMCategory instanceVariableNames: 'name functions' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Core'! !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/7/2003 20:09'! categoryPostfix ^'-Functional'! ! !PMCategory class methodsFor: 'private' stamp: 'lr 12/4/2003 13:12'! categoryPrefix ^'*'! ! !PMCategory class methodsFor: 'instance creation' stamp: 'lr 12/4/2003 13:03'! name: aString ^self new name: aString; yourself! ! !PMCategory methodsFor: 'comparing' stamp: 'lr 12/5/2003 21:14'! = anObject ^self class = anObject class and: [ self name = anObject name ]! ! !PMCategory methodsFor: 'visiting' stamp: 'lr 12/2/2003 19:12'! acceptVisitor: aVisitor aVisitor visitCategory: self! ! !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: '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: '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: 'accessing' stamp: 'lr 12/5/2003 20:43'! functions ^functions! ! !PMCategory methodsFor: 'accessing' stamp: 'lr 1/18/2004 11:39'! functionsFor: aSelector ^ClassOrganizer allCategory = aSelector ifTrue: [ self functions ] ifFalse: [ self functions select: [ :each | each selector = aSelector ] ]! ! !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: 'comparing' stamp: 'lr 12/5/2003 21:13'! hash ^name hash! ! !PMCategory methodsFor: 'private-building' stamp: 'lr 12/7/2003 20:29'! install PMBuilder visit: self! ! !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: '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: 'accessing' stamp: 'lr 12/4/2003 13:02'! name ^name! ! !PMCategory methodsFor: 'private' stamp: 'lr 12/6/2003 13:50'! name: aString name := aString. self refresh.! ! !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-building' stamp: 'lr 12/7/2003 20:30'! reinstall self uninstall; install! ! !PMCategory methodsFor: 'actions' stamp: 'lr 12/8/2003 22:08'! remove: aFunction self functions remove: aFunction. self reinstall.! ! !PMCategory methodsFor: 'actions' stamp: 'lr 12/8/2003 22:09'! removeAll self uninstall; refresh ! ! !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: 'accessing' stamp: 'lr 1/18/2004 11:31'! selectors ^self groups collect: [ :each | each first selector ]! ! !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 ] ].! ! PMNode subclass: #PMExpression instanceVariableNames: 'source node' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Core'! !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: '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.! ! !PMExpression methodsFor: 'comparing' stamp: 'lr 12/5/2003 21:51'! hash ^self node hash! ! !PMExpression methodsFor: 'accessing' stamp: 'lr 12/4/2003 17:35'! node ^node! ! !PMExpression methodsFor: 'accessing' stamp: 'lr 12/4/2003 17:38'! node: aNode node := aNode! ! !PMExpression methodsFor: 'accessing' stamp: 'lr 12/3/2003 21:56'! source ^source! ! !PMExpression methodsFor: 'accessing' stamp: 'lr 12/3/2003 21:56'! source: aString source := aString! ! PMNode subclass: #PMFunction instanceVariableNames: 'receiver arguments condition body mapping' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Core'! !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 class methodsFor: 'configuration' stamp: 'lr 12/4/2003 20:40'! argumentPrefix ^'t'! ! !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 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 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: '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: 'visiting' stamp: 'lr 12/2/2003 19:32'! acceptVisitor: aVisitor aVisitor visitFunction: self! ! !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: '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: $" ] ] ! ! !PMFunction methodsFor: 'printing' stamp: 'lr 12/4/2003 10:13'! asString ^String streamContents: [ :stream | PMFunctionPrinter print: self on: stream ]! ! !PMFunction methodsFor: 'printing' stamp: 'lr 12/4/2003 10:13'! asText ^Text streamContents: [ :stream | PMFunctionPrinter print: self on: stream ]! ! !PMFunction methodsFor: 'accessing' stamp: 'lr 12/1/2003 20:14'! body ^body! ! !PMFunction methodsFor: 'private' stamp: 'lr 12/31/2003 16:42'! buildArgumentMapping ^(PMArgumentMapper visit: self) mapping! ! !PMFunction methodsFor: 'accessing' stamp: 'lr 12/2/2003 10:14'! condition ^condition! ! !PMFunction methodsFor: 'testing' stamp: 'lr 12/2/2003 19:34'! hasArguments ^arguments first isMatched! ! !PMFunction methodsFor: 'testing' stamp: 'lr 12/2/2003 19:32'! hasBody ^body notNil! ! !PMFunction methodsFor: 'testing' stamp: 'lr 12/2/2003 09:27'! hasCondition ^condition notNil! ! !PMFunction methodsFor: 'comparing' stamp: 'lr 12/5/2003 21:50'! hash ^receiver hash bitXor: (arguments hash bitXor: condition hash)! ! !PMFunction methodsFor: 'accessing' stamp: 'lr 12/31/2003 16:22'! mapping ^mapping! ! !PMFunction methodsFor: 'utility' stamp: 'lr 12/5/2003 00:07'! numArgs ^self hasArguments ifTrue: [ arguments size ] ifFalse: [ 0 ]! ! !PMFunction methodsFor: 'printing' stamp: 'lr 12/4/2003 10:02'! printOn: aStream PMSelectorPrinter print: self on: aStream! ! !PMFunction methodsFor: 'accessing' stamp: 'lr 12/2/2003 19:56'! receiver ^receiver! ! !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: '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: 'utility' stamp: 'lr 12/10/2003 09:48'! target ^self receiver target! ! !PMNode methodsFor: 'visiting' stamp: 'lr 12/2/2003 08:40'! acceptVisitor: aVisitor self subclassResponsibility! ! !PMNode methodsFor: 'testing' stamp: 'lr 12/31/2003 22:44'! isPattern ^false! ! !PMNode methodsFor: 'testing' stamp: 'lr 12/10/2003 09:59'! isSelector ^false! ! !PMNode methodsFor: 'accessing' stamp: 'lr 12/8/2003 19:12'! parent ^parent! ! !PMNode methodsFor: 'accessing' stamp: 'lr 12/8/2003 19:12'! parent: aNode parent := aNode! ! PMNode subclass: #PMPattern instanceVariableNames: 'alias' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Core'! 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 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: 'visiting' stamp: 'lr 12/1/2003 23:14'! acceptVisitor: aVisitor aVisitor visitListPattern: self! ! !PMListPattern methodsFor: 'accessing-items' stamp: 'lr 12/8/2003 19:10'! add: aPattern aPattern parent: self. items addLast: aPattern.! ! !PMListPattern methodsFor: 'accessing-items' stamp: 'lr 12/8/2003 18:31'! addAll: aCollection aCollection do: [ :each | self add: each ]! ! !PMListPattern methodsFor: 'testing' stamp: 'lr 12/8/2003 22:41'! hasTail ^false! ! !PMListPattern methodsFor: 'comparing' stamp: 'lr 12/8/2003 18:20'! hash ^self items hash! ! !PMListPattern methodsFor: 'initialization' stamp: 'lr 2/9/2007 09:49'! initialize super initialize. items := OrderedCollection new! ! !PMListPattern methodsFor: 'testing' stamp: 'lr 12/8/2003 18:20'! isEmpty ^items isEmpty! ! !PMListPattern methodsFor: 'accessing' stamp: 'lr 12/8/2003 18:19'! items ^items! ! !PMListPattern methodsFor: 'accessing' stamp: 'lr 12/8/2003 18:19'! items: aCollection items := aCollection! ! !PMListPattern methodsFor: 'accessing-items' stamp: 'lr 12/8/2003 20:49'! size ^items size! ! !PMListPattern methodsFor: 'tools' stamp: 'lr 12/10/2003 09:49'! target ^SequenceableCollection! ! PMListPattern subclass: #PMOpenListPattern instanceVariableNames: 'tail' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Core'! !PMOpenListPattern class methodsFor: 'instance-creation' stamp: 'lr 12/8/2003 18:35'! head: aCollection tail: aPattern ^(self head: aCollection) tail: aPattern; yourself! ! !PMOpenListPattern methodsFor: 'comparing' stamp: 'lr 12/8/2003 22:50'! = anObject ^super = anObject and: [ self tail = anObject tail ]! ! !PMOpenListPattern methodsFor: 'visiting' stamp: 'lr 12/8/2003 18:25'! acceptVisitor: aVisitor aVisitor visitOpenListPattern: self! ! !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 methodsFor: 'accessing' stamp: 'lr 12/8/2003 18:22'! tail ^tail! ! !PMOpenListPattern methodsFor: 'accessing' stamp: 'lr 12/8/2003 19:11'! tail: aPattern aPattern parent: self. tail := aPattern.! ! PMPattern subclass: #PMObjectPattern instanceVariableNames: 'object' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Core'! !PMObjectPattern class methodsFor: 'instance creation' stamp: 'lr 12/1/2003 21:15'! object: anObject ^self new object: anObject yourself! ! !PMObjectPattern methodsFor: 'comparing' stamp: 'lr 12/31/2003 16:55'! = anObject ^super = anObject and: [ self object = anObject object ]! ! !PMObjectPattern methodsFor: 'visiting' stamp: 'lr 12/1/2003 23:14'! acceptVisitor: aVisitor aVisitor visitObjectPattern: self! ! !PMObjectPattern methodsFor: 'comparing' stamp: 'lr 12/5/2003 21:16'! hash ^self object hash! ! !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: 'tools' stamp: 'lr 12/10/2003 09:49'! target ^self object class! ! !PMPattern methodsFor: 'comparing' stamp: 'lr 1/11/2004 14:45'! = anObject ^self class = anObject class and: [ self name = anObject name ] and: [ self alias = anObject alias ]! ! !PMPattern methodsFor: 'visiting' stamp: 'lr 12/1/2003 23:13'! acceptVisitor: aVisitor aVisitor visitPattern: self! ! !PMPattern methodsFor: 'accessing' stamp: 'lr 1/11/2004 15:05'! alias ^alias! ! !PMPattern methodsFor: 'accessing' stamp: 'lr 1/11/2004 14:45'! alias: aString alias := aString! ! !PMPattern methodsFor: 'testing' stamp: 'lr 1/11/2004 15:05'! hasAlias ^self alias notNil! ! !PMPattern methodsFor: 'testing' stamp: 'lr 12/4/2003 17:15'! hasName ^self name notNil! ! !PMPattern methodsFor: 'comparing' stamp: 'lr 1/11/2004 14:45'! hash ^self name hash bitXor: self alias hash! ! !PMPattern methodsFor: 'testing' stamp: 'lr 12/31/2003 22:44'! isPattern ^true! ! !PMPattern methodsFor: 'testing' stamp: 'lr 12/10/2003 10:00'! isReceiver ^self parent isSelector not! ! !PMPattern methodsFor: 'tools' stamp: 'lr 12/4/2003 17:16'! name ^nil! ! !PMPattern methodsFor: 'tools' stamp: 'lr 12/10/2003 09:48'! target self subclassResponsibility! ! PMPattern subclass: #PMVariablePattern instanceVariableNames: 'name' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Core'! PMVariablePattern subclass: #PMBlockPattern instanceVariableNames: 'expression' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Core'! !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/31/2003 16:56'! = anObject ^super = anObject and: [ self expression = anObject expression ]! ! !PMBlockPattern methodsFor: 'visiting' stamp: 'lr 12/4/2003 10:18'! acceptVisitor: aVisitor aVisitor visitBlockPattern: self! ! !PMBlockPattern methodsFor: 'accessing' stamp: 'lr 12/4/2003 10:17'! expression ^expression! ! !PMBlockPattern methodsFor: 'accessing' stamp: 'lr 12/8/2003 19:16'! expression: anExpression anExpression parent: self. expression := anExpression.! ! !PMBlockPattern methodsFor: 'comparing' stamp: 'lr 12/5/2003 22:42'! hash ^self expression hash! ! PMVariablePattern subclass: #PMClassPattern instanceVariableNames: 'target' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Core'! !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: 'comparing' stamp: 'lr 12/5/2003 22:42'! hash ^self target hash! ! !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: 'accessing' stamp: 'lr 12/5/2003 21:07'! target ^target! ! !PMClassPattern methodsFor: 'accessing' stamp: 'lr 12/5/2003 21:08'! target: aClass target := aClass! ! !PMVariablePattern class methodsFor: 'instance-creation' stamp: 'lr 12/1/2003 21:43'! name: aString ^self new name: aString; yourself! ! !PMVariablePattern methodsFor: 'visiting' stamp: 'lr 12/1/2003 23:14'! acceptVisitor: aVisitor aVisitor visitVariablePattern: self! ! !PMVariablePattern methodsFor: 'accessing' stamp: 'lr 12/1/2003 21:41'! name ^name! ! !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! ! PMNode subclass: #PMSelector instanceVariableNames: 'selector' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Core'! PMSelector subclass: #PMMatchedSelector instanceVariableNames: 'pattern' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Core'! !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: 'visiting' stamp: 'lr 12/2/2003 09:13'! acceptVisitor: aVisitor aVisitor visitMatchedSelector: self! ! !PMMatchedSelector methodsFor: 'comparing' stamp: 'lr 12/5/2003 21:19'! hash ^self selector hash bitXor: self pattern hash! ! !PMMatchedSelector methodsFor: 'testing' stamp: 'lr 12/2/2003 19:34'! isMatched ^true! ! !PMMatchedSelector methodsFor: 'accessing' stamp: 'lr 12/2/2003 08:51'! pattern ^pattern! ! !PMMatchedSelector methodsFor: 'accessing' stamp: 'lr 12/8/2003 19:17'! pattern: aPattern aPattern parent: self. pattern := aPattern.! ! !PMSelector class methodsFor: 'instance creation' stamp: 'lr 12/2/2003 08:49'! selector: aSymbol ^self new selector: aSymbol; yourself! ! !PMSelector methodsFor: 'comparing' stamp: 'lr 12/5/2003 21:18'! = anObject ^self class = anObject class and: [ self selector = anObject selector ]! ! !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'! 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 methodsFor: 'accessing' stamp: 'lr 12/2/2003 08:43'! selector ^selector! ! !PMSelector methodsFor: 'accessing' stamp: 'lr 12/2/2003 08:43'! selector: aSymbol selector := aSymbol! ! Object subclass: #PMVisitor instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Visitor'! PMVisitor subclass: #PMBuilder instanceVariableNames: 'target methodNode category function' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Visitor'! !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:18'! buildFunctionBody ^RBBlockNode body: (self buildFunctionBlock)! ! !PMBuilder methodsFor: 'building' stamp: 'lr 12/10/2003 09:53'! buildFunctionMatcher ^(PMConditionBuilder target: target visit: function) condition! ! !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: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: '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: '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: 'visiting' stamp: 'lr 12/5/2003 22:21'! visitFunction: aFunction function := aFunction. methodNode addNode: self buildFunction! ! PMVisitor subclass: #PMPrinter instanceVariableNames: 'stream' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Visitor'! !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: 'accessing' stamp: 'lr 12/4/2003 10:03'! contents ^self stream contents! ! !PMPrinter methodsFor: 'private' stamp: 'lr 12/4/2003 10:03'! stream ^stream! ! !PMPrinter methodsFor: 'private' stamp: 'lr 12/4/2003 10:02'! stream: aStream stream := aStream! ! PMPrinter subclass: #PMSelectorPrinter instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Visitor'! 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: 'utility' stamp: 'lr 1/11/2004 14:57'! visitAlias: aPattern aPattern hasAlias ifTrue: [ stream nextPutAll: ' as '. stream nextPutAll: aPattern alias ].! ! !PMSelectorPrinter methodsFor: 'visiting' stamp: 'lr 1/11/2004 16:04'! visitBlockPattern: aPattern stream nextPutAll: '[ :'. stream nextPutAll: aPattern name. stream nextPutAll: ' |'. self visit: aPattern expression. stream nextPut: $]. self visitAlias: aPattern.! ! !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 ].! ! !PMSelectorPrinter methodsFor: 'visiting' stamp: 'lr 1/11/2004 15:49'! visitListPattern: aPattern stream nextPut: ${. self visitAll: aPattern items separatedBy: [ stream nextPutAll: '. ' ]. stream nextPut: $}. self visitAlias: aPattern.! ! !PMSelectorPrinter methodsFor: 'visiting' stamp: 'lr 1/11/2004 15:00'! visitMatchedSelector: aSelector stream nextPutAll: aSelector selector; space. self visit: aSelector pattern.! ! !PMSelectorPrinter methodsFor: 'visiting' stamp: 'lr 1/11/2004 15:00'! visitObjectPattern: aPattern stream print: aPattern object. self visitAlias: aPattern.! ! !PMSelectorPrinter methodsFor: 'visiting' stamp: 'lr 1/11/2004 16:02'! visitOpenListPattern: aPattern stream nextPut: ${. self visitAll: aPattern items separatedBy: [ stream nextPutAll: '. ' ]. (aPattern items last target = Symbol and: [ aPattern items last hasAlias not ]) ifTrue: [ stream nextPut: $. ]. stream nextPut: $|. self visit: aPattern tail. stream nextPut: $}. self visitAlias: aPattern.! ! !PMSelectorPrinter methodsFor: 'visiting' stamp: 'lr 12/3/2003 22:02'! visitSelector: aSelector stream nextPutAll: aSelector selector.! ! !PMSelectorPrinter methodsFor: 'visiting' stamp: 'lr 1/11/2004 15:00'! visitVariablePattern: aPattern stream nextPutAll: aPattern name. self visitAlias: 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 1/11/2004 17:28'! applyMapping mapping keysAndValuesDo: [ :source :target | self rewrite: expressions from: source to: target first ].! ! !PMArgumentMapper methodsFor: 'private' stamp: 'lr 1/11/2004 15:06'! 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: 'private' stamp: 'lr 1/11/2004 16:18'! definePattern: aPattern aPattern hasAlias ifTrue: [ ^self defineMapping: aPattern alias ]. aPattern hasName ifTrue: [ ^self defineMapping: aPattern name ].! ! !PMArgumentMapper methodsFor: 'initialization' stamp: 'lr 2/9/2007 09:49'! initialize super initialize. mapping := Dictionary new. expressions := OrderedCollection new! ! !PMArgumentMapper methodsFor: 'accessing' stamp: 'lr 12/4/2003 22:37'! mapping ^mapping! ! !PMArgumentMapper methodsFor: 'private' stamp: 'lr 1/11/2004 17:28'! rewrite: aCollection from: aSourceNode to: aTargetNode | rewriter | rewriter := ParseTreeRewriter new. rewriter replaceTree: aSourceNode withTree: aTargetNode. aCollection do: [ :each | (rewriter executeTree: each node) ifTrue: [ each node: rewriter tree ] ]! ! !PMArgumentMapper methodsFor: 'visiting' stamp: 'lr 1/11/2004 17:31'! visitBlockPattern: aPattern super visitBlockPattern: aPattern. aPattern hasAlias ifTrue: [ self rewrite: (Array with: aPattern expression) from: (RBVariableNode named: aPattern name) to: self top ] ifFalse: [ self visit: aPattern expression ].! ! !PMArgumentMapper methodsFor: 'visiting' stamp: 'lr 12/8/2003 20:15'! visitExpression: anExpression expressions add: anExpression! ! !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 1/11/2004 16:26'! visitPattern: aPattern self definePattern: aPattern.! ! PMStackedVisitor subclass: #PMConditionBuilder instanceVariableNames: 'conditions target' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Visitor'! !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'! addNode: aNode conditions addLast: aNode! ! !PMConditionBuilder methodsFor: 'utility' stamp: 'lr 12/8/2003 23:06'! addSelector: aSymbol self addNode: (RBMessageNode receiver: self top selector: aSymbol)! ! !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: '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: '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: 'initialization' stamp: 'lr 2/9/2007 09:49'! initialize super initialize. conditions := OrderedCollection new! ! !PMConditionBuilder methodsFor: 'accessing' stamp: 'lr 12/10/2003 09:54'! target ^target! ! !PMConditionBuilder methodsFor: 'accessing' stamp: 'lr 12/10/2003 09:54'! target: aClass target := aClass! ! !PMConditionBuilder methodsFor: 'visiting' stamp: 'lr 12/8/2003 22:24'! visitBlockPattern: aPattern self visit: aPattern expression! ! !PMConditionBuilder methodsFor: 'visiting' stamp: 'lr 2/9/2007 08:47'! 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: 'visiting' stamp: 'lr 12/8/2003 22:28'! visitExpression: anExpression self addNode: anExpression node! ! !PMConditionBuilder methodsFor: 'visiting' stamp: 'lr 12/31/2003 16:47'! visitFunction: aFunction super visitFunction: aFunction. self buildEqualArguments: aFunction. self visit: aFunction condition.! ! !PMConditionBuilder methodsFor: 'visiting' stamp: 'lr 2/9/2007 08:46'! visitListPattern: aPattern self visitClassPattern: aPattern. self pushSelector: #size do: [ self addSelector: (aPattern hasTail ifTrue: [ #>= ] ifFalse: [ #= ]) argument: aPattern size ]. super visitListPattern: aPattern.! ! !PMConditionBuilder methodsFor: 'visiting' stamp: 'lr 2/9/2007 08:46'! visitObjectPattern: aPattern self addSelector: #= argument: aPattern object! ! !PMStackedVisitor methodsFor: 'initialization' stamp: 'lr 2/9/2007 09:49'! initialize super initialize. self removeAll! ! !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:58'! pushSelector: aSymbol argument: aValue do: aBlock self push: (RBMessageNode receiver: self top selector: aSymbol arguments: {RBLiteralNode value: aValue}) do: aBlock ! ! !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: 'private' stamp: 'lr 12/31/2003 15:49'! pushVariable: aString do: aBlock self push: (RBVariableNode named: aString) do: aBlock ! ! !PMStackedVisitor methodsFor: 'utility' stamp: 'lr 12/8/2003 22:13'! removeAll stack := OrderedCollection new.! ! !PMStackedVisitor methodsFor: 'utility' stamp: 'lr 12/8/2003 21:53'! top ^stack last copy! ! !PMStackedVisitor methodsFor: 'visiting' stamp: 'lr 1/11/2004 16:29'! 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: 'visiting' stamp: 'lr 1/11/2004 16:09'! visitListPattern: aPattern super visitListPattern: aPattern. aPattern items withIndexDo: [ :each :pos | self pushSelector: #at: argument: pos do: [ self visit: each ] ]! ! !PMStackedVisitor methodsFor: 'visiting' stamp: 'lr 1/11/2004 16:29'! visitMatchedSelector: aSelector self visit: aSelector pattern.! ! !PMStackedVisitor methodsFor: 'visiting' stamp: 'lr 1/11/2004 16:27'! visitOpenListPattern: aPattern super visitOpenListPattern: aPattern. self pushSelector: #allButFirst: argument: aPattern size do: [ self visit: aPattern tail ]! ! !PMVisitor class methodsFor: 'instance creation' stamp: 'lr 12/2/2003 19:10'! visit: aNode ^self new visit: aNode; yourself! ! !PMVisitor methodsFor: 'utility' stamp: 'lr 12/1/2003 23:12'! visit: anObject anObject acceptVisitor: self.! ! !PMVisitor methodsFor: 'utility' stamp: 'lr 12/1/2003 23:12'! visitAll: aCollection aCollection do: [ :each | each acceptVisitor: self ].! ! !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/4/2003 10:25'! visitBlockPattern: aPattern self visitVariablePattern: aPattern.! ! !PMVisitor methodsFor: 'visiting' stamp: 'lr 12/2/2003 19:13'! visitCategory: aCategory self visitAll: aCategory functions! ! !PMVisitor methodsFor: 'visiting' stamp: 'lr 12/1/2003 23:11'! visitClassPattern: aPattern self visitVariablePattern: aPattern.! ! !PMVisitor methodsFor: 'visiting' stamp: 'lr 12/3/2003 21:59'! visitExpression: anExpression! ! !PMVisitor methodsFor: 'visiting' stamp: 'lr 1/11/2004 16:17'! visitFunction: aFunction! ! !PMVisitor methodsFor: 'visiting' stamp: 'lr 1/11/2004 16:17'! visitListPattern: aPattern self visitPattern: aPattern.! ! !PMVisitor methodsFor: 'visiting' stamp: 'lr 1/11/2004 16:17'! visitMatchedSelector: aSelector self visitSelector: aSelector.! ! !PMVisitor methodsFor: 'visiting' stamp: 'lr 12/2/2003 09:05'! visitObjectPattern: aPattern self visitPattern: aPattern.! ! !PMVisitor methodsFor: 'visiting' stamp: 'lr 1/11/2004 16:17'! visitOpenListPattern: aPattern self visitListPattern: aPattern.! ! !PMVisitor methodsFor: 'visiting' stamp: 'lr 12/4/2003 17:14'! visitPattern: aPattern! ! !PMVisitor methodsFor: 'visiting' stamp: 'lr 12/2/2003 09:06'! visitSelector: aSelector! ! !PMVisitor methodsFor: 'visiting' stamp: 'lr 12/2/2003 09:06'! visitVariablePattern: aPattern self visitPattern: aPattern.! ! !UndefinedObject methodsFor: '*pattern' stamp: 'lr 12/3/2003 22:00'! acceptVisitor: aVisitor! ! !Integer methodsFor: '*Pattern-Examples-Functional' stamp: 'lr 1/11/2004 17:12'! 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: { })! !