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 12/9/2003 10:08'! parserDefinitionComment "Message : Pattern 'receiver' "">>"" Selector 'selector' Body 'body' { PMFunction receiver: receiver arguments: selector body: body } | Pattern 'receiver' "">>"" Selector 'selector' Condition 'condition' Body 'body' { PMFunction receiver: receiver arguments: selector condition: condition body: body } ; # S E L E C O R S # # # #Ê# # # # # #Ê# # # # # #Ê# # # # # #Ê# # # # # #Ê# # # # # #Ê# # # # # #Ê# # # # # #Ê# # Selector : UnarySelector | BinarySelector | KeywordSelector+ ; UnarySelector : { PMSelector selector: '1' value asSymbol } ; BinarySelector : Pattern { PMMatchedSelector selector: '1' value asSymbol pattern: '2' } ; KeywordSelector : Pattern { PMMatchedSelector selector: '1' value asSymbol pattern: '2' } ; # P A T T E R N # # # #Ê# # # # # #Ê# # # # # #Ê# # # # # #Ê# # # # # #Ê# # # # # #Ê# # # # # #Ê# # # # # #Ê# # Pattern : Object { #liftFirstValue: } | Class { #liftFirstValue: } | Variable { #liftFirstValue: } | List { #liftFirstValue: } | Block { #liftFirstValue: } ; Object : ""true"" { PMObjectPattern object: true } | ""false"" { PMObjectPattern object: false } | ""nil"" { PMObjectPattern object: nil } | { PMObjectPattern object: '1' value asNumber } | { PMObjectPattern object: '1' value second } | { PMObjectPattern object: '1' value allButFirst allButLast } | ""#"" { PMObjectPattern object: '2' value allButFirst allButLast asSymbol } | ""#"" { PMObjectPattern object: '2' value asSymbol } | ""#"" { PMObjectPattern object: '2' value asSymbol } | ""#"" { PMObjectPattern object: '2' value asSymbol } | ""#"" { PMObjectPattern object: '2' value asSymbol } ; Class : { PMClassPattern name: '1' value } ; Variable : { PMVariablePattern name: '1' value } ; List : ""{"" ""}"" { PMListPattern empty } | ""{"" ListEntries 'items' "".""? ""}"" { PMListPattern head: items } | ""{"" ListEntries 'items' "".""? ""|"" Pattern 'tail' ""}"" { PMOpenListPattern head: items tail: tail } ; ListEntries : Pattern 'pattern' { OrderedCollection with: pattern } | ListEntries 'list' ""."" Pattern 'pattern' { list add: pattern; yourself } ; Block : ""["" "":"" 'variable' ""|"" { PMBlockPattern name: variable value expression: self parseCondition } ; # S M A L L T A K # # # #Ê# # # # # #Ê# # # # # #Ê# # # # # #Ê# # # # # #Ê# # # # # #Ê# # # # # #Ê# # # # # #Ê# # Condition : ""if:"" ""["" { self parseCondition } ; Body : { self parseBody } ;"! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/9/2003 10:08'! reduceActionForObject11: nodes ^PMObjectPattern object: (nodes at: 2) value asSymbol! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/9/2003 10:08'! reduceActionForObject9: nodes ^PMObjectPattern object: (nodes at: 2) value asSymbol! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/9/2003 10:08'! reduceActionForBlock1: nodes ^PMBlockPattern name: (nodes at: 3) value expression: self parseCondition! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/9/2003 10:08'! reduceActionForMessage1: nodes ^PMFunction receiver: (nodes at: 1) arguments: (nodes at: 3) body: (nodes at: 4)! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/9/2003 10:08'! reduceActionForRepeatXMultipleXXKeywordSelector1: nodes ^OrderedCollection with: (nodes at: 1)! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/9/2003 10:08'! reduceActionForBinarySelector1: nodes ^PMMatchedSelector selector: (nodes at: 1) value asSymbol pattern: (nodes at: 2)! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/9/2003 10:08'! reduceActionForUnarySelector1: nodes ^PMSelector selector: (nodes at: 1) value asSymbol! ! !PMParser class methodsFor: 'generated-accessing' stamp: 'lr 12/9/2003 10:08'! scannerClass ^PMScanner! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/9/2003 10:08'! reduceActionForListEntries2: nodes ^(nodes at: 1) add: (nodes at: 3); yourself! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/9/2003 10:08'! reduceActionForMessage2: nodes ^PMFunction receiver: (nodes at: 1) arguments: (nodes at: 3) condition: (nodes at: 4) body: (nodes at: 5)! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/9/2003 10:08'! reduceActionForObject6: nodes ^PMObjectPattern object: (nodes at: 1) value allButFirst allButLast! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/9/2003 10:08'! reduceActionForCondition1: nodes ^self parseCondition! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/9/2003 10:08'! reduceActionForObject3: nodes ^PMObjectPattern object: nil! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/9/2003 10:08'! reduceActionForKeywordSelector1: nodes ^PMMatchedSelector selector: (nodes at: 1) value asSymbol pattern: (nodes at: 2)! ! !PMParser class methodsFor: 'generated-starting states' stamp: 'lr 12/9/2003 10:08'! startingStateForMessage ^1! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/9/2003 10:08'! reduceActionForOptionalXXXXX1: nodes ^nil! ! !PMParser methodsFor: 'generated-tables' stamp: 'lr 12/9/2003 10:08'! transitionTable ^#( #(3 9 1 13 3 17 5 21 6 25 7 29 8 33 13 37 14 41 15 45 16 49 21 53 25 57 26 61 27 65 28 69 29 73 30 77 35) #(2 38 2 4 9 11 12 17 38) #(2 30 2 4 9 11 12 17 38) #(2 34 2 4 9 11 12 17 38) #(3 81 14 85 16 89 17 93 18 97 19) #(3 9 1 13 3 17 5 21 6 25 7 29 8 101 11 33 13 37 14 41 15 45 16 49 21 57 26 61 27 65 28 69 29 73 30 105 35 109 36) #(2 113 10) #(2 74 2 4 9 11 12 17 38) #(2 78 2 4 9 11 12 17 38) #(2 42 2 4 9 11 12 17 38) #(2 50 2 4 9 11 12 17 38) #(2 46 2 4 9 11 12 17 38) #(2 0 38) #(2 122 2 4 9 11 12 17 38) #(2 126 2 4 9 11 12 17 38) #(2 130 2 4 9 11 12 17 38) #(2 134 2 4 9 11 12 17 38) #(2 138 2 4 9 11 12 17 38) #(2 117 4) #(2 58 2 4 9 11 12 17 38) #(2 54 2 4 9 11 12 17 38) #(2 66 2 4 9 11 12 17 38) #(2 70 2 4 9 11 12 17 38) #(2 62 2 4 9 11 12 17 38) #(2 82 2 4 9 11 12 17 38) #(2 142 9 11 12) #(3 150 9 150 11 121 12 125 37) #(2 129 14) #(3 133 14 137 17 141 19 145 22 149 23 153 32 157 34 161 40) #(3 9 1 13 3 17 5 21 6 25 7 29 8 154 9 154 11 33 13 37 14 41 15 45 16 49 21 57 26 61 27 65 28 69 29 73 30 165 35) #(3 169 9 173 11) #(2 177 9) #(2 14 2 38) #(3 9 1 13 3 17 5 21 6 25 7 29 8 33 13 37 14 41 15 45 16 49 21 57 26 61 27 65 28 69 29 73 30 181 35) #(3 9 1 13 3 17 5 21 6 25 7 29 8 33 13 37 14 41 15 45 16 49 21 57 26 61 27 65 28 69 29 73 30 185 35) #(3 118 2 137 17 189 32 118 38) #(2 110 2 38) #(2 6 2 17 38) #(3 193 2 197 31 201 33 106 38) #(2 114 2 38) #(2 146 9 11 12) #(3 9 1 13 3 17 5 21 6 25 7 29 8 33 13 37 14 41 15 45 16 49 21 57 26 61 27 65 28 69 29 73 30 205 35) #(2 86 2 4 9 11 12 17 38) #(2 94 2 4 9 11 12 17 38) #(2 102 2 17 38) #(2 158 2 38) #(2 10 2 17 38) #(2 209 8) #(3 213 33 106 38) #(2 22 38) #(2 217 11) #(2 98 38) #(2 26 38) #(2 90 2 4 9 11 12 17 38) )! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/9/2003 10:08'! reduceActionForClass1: nodes ^PMClassPattern name: (nodes at: 1) value! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/9/2003 10:08'! reduceActionForList3: nodes ^PMOpenListPattern head: (nodes at: 2) tail: (nodes at: 5)! ! !PMParser methodsFor: 'generated-tables' stamp: 'lr 12/9/2003 10:08'! reduceTable ^#( #(22 1 #reduceActionForRepeatXMultipleXXKeywordSelector1:) #(22 2 #reduceActionForRepeatXMultipleXXKeywordSelector2:) #(23 1 #reduceActionForUnarySelector1:) #(24 1 #reduceFor:) #(25 4 #reduceActionForMessage1:) #(25 5 #reduceActionForMessage2:) #(26 1 #reduceActionForObject1:) #(26 1 #reduceActionForObject2:) #(26 1 #reduceActionForObject3:) #(26 1 #reduceActionForObject4:) #(26 1 #reduceActionForObject5:) #(26 1 #reduceActionForObject6:) #(26 2 #reduceActionForObject7:) #(26 2 #reduceActionForObject8:) #(26 2 #reduceActionForObject9:) #(26 2 #reduceActionForObject10:) #(26 2 #reduceActionForObject11:) #(27 1 #reduceActionForClass1:) #(28 1 #reduceActionForVariable1:) #(29 2 #reduceActionForList1:) #(29 4 #reduceActionForList2:) #(29 6 #reduceActionForList3:) #(30 4 #reduceActionForBlock1:) #(31 2 #reduceActionForCondition1:) #(32 2 #reduceActionForKeywordSelector1:) #(33 0 #reduceActionForBody1:) #(34 1 #reduceFor:) #(34 1 #reduceFor:) #(34 1 #reduceFor:) #(35 1 #liftFirstValue:) #(35 1 #liftFirstValue:) #(35 1 #liftFirstValue:) #(35 1 #liftFirstValue:) #(35 1 #liftFirstValue:) #(36 1 #reduceActionForListEntries1:) #(36 3 #reduceActionForListEntries2:) #(37 0 #reduceActionForOptionalXXXXX1:) #(37 1 #reduceActionForOptionalXXXXX2:) #(40 2 #reduceActionForBinarySelector1:) )! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/9/2003 10:08'! reduceActionForObject1: nodes ^PMObjectPattern object: true! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/9/2003 10:08'! reduceActionForListEntries1: nodes ^OrderedCollection with: (nodes at: 1)! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/9/2003 10:08'! reduceActionForVariable1: nodes ^PMVariablePattern name: (nodes at: 1) value! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/9/2003 10:08'! reduceActionForObject5: nodes ^PMObjectPattern object: (nodes at: 1) value second! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/9/2003 10:08'! reduceActionForBody1: nodes ^self parseBody! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/9/2003 10:08'! reduceActionForList1: nodes ^PMListPattern empty! ! !PMParser methodsFor: 'actions' stamp: 'lr 12/4/2003 17:35'! parseExpression: anAssociation | source node | anAssociation isNil ifTrue: [ self reportError: 0 ]. source _ anAssociation value. node _ RBParser parseExpression: source onError: [ :error :position | scanner position: anAssociation key + (source size min: position). currentToken _ nil. self reportErrorMessage: error ]. currentToken _ scanner next. ^PMExpression source: source node: node! ! !PMParser methodsFor: 'actions' stamp: 'lr 12/3/2003 21:58'! parseCondition ^self parseExpression: (scanner scanBlockFrom: currentToken)! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/9/2003 10:08'! reduceActionForObject4: nodes ^PMObjectPattern object: (nodes at: 1) value asNumber! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/9/2003 10:08'! reduceActionForList2: nodes ^PMListPattern head: (nodes at: 2)! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/9/2003 10:08'! reduceActionForObject10: nodes ^PMObjectPattern object: (nodes at: 2) value asSymbol! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/9/2003 10:08'! reduceActionForObject7: nodes ^PMObjectPattern object: (nodes at: 2) value allButFirst allButLast asSymbol! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/9/2003 10:08'! reduceActionForObject2: nodes ^PMObjectPattern object: false! ! !PMParser methodsFor: 'actions' stamp: 'lr 12/3/2003 21:58'! parseBody ^self parseExpression: (scanner scanUpToEndFrom: currentToken)! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/9/2003 10:08'! reduceActionForObject8: nodes ^PMObjectPattern object: (nodes at: 2) value asSymbol! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/9/2003 10:08'! reduceActionForRepeatXMultipleXXKeywordSelector2: nodes ^(nodes at: 1) add: (nodes at: 2); yourself! ! !PMParser methodsFor: 'actions' stamp: 'lr 12/3/2003 18:46'! handleError: anInteger | result | 1 to: self emptySymbolTokenId do: [ :each | result _ self actionFor: each. (result bitAnd: self actionMask) = self reduceAction ifTrue: [ ^self reduce: (result bitShift: -2) ] ]. super handleError: anInteger! ! !PMParser methodsFor: 'generated-reduction actions' stamp: 'lr 12/9/2003 10:08'! reduceActionForOptionalXXXXX2: nodes ^nodes at: 1! ! SmaCCScanner subclass: #PMScanner instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Parsing'! !PMScanner methodsFor: 'generated-scanner' stamp: 'lr 12/9/2003 10:08'! scan5 [self recordMatch: #(13 14). self step. currentCharacter isDigit or: [(currentCharacter between: $A and: $Z) or: [currentCharacter between: $a and: $z]]] whileTrue. currentCharacter == $: ifTrue: [^self scan6]. ^self reportLastMatch! ! !PMScanner methodsFor: 'actions' stamp: 'lr 12/3/2003 22:39'! scanBlockFrom: aToken | level first result char | self scanBackwardsFrom: aToken. level _ 1. first _ stream position. result _ WriteStream on: String new. [ stream atEnd ] whileFalse: [ char _ stream next. char == $[ ifTrue: [ level _ level + 1 ]. char == $] ifTrue: [ level _ level - 1. level isZero ifTrue: [ ^first -> result contents ] ]. result nextPut: char ]. ^nil! ! !PMScanner methodsFor: 'actions' stamp: 'lr 12/3/2003 22:39'! scanUpToEndFrom: aToken self scanBackwardsFrom: aToken. ^stream position -> stream upToEnd asString! ! !PMScanner class methodsFor: 'generated-initialization' stamp: 'lr 12/9/2003 10:08'! initializeKeywordMap keywordMap := Dictionary new. #(#(14 'false' 5) #(14 'nil' 1) #(14 'true' 3)) do: [:each | (keywordMap at: each first ifAbsentPut: [Dictionary new]) at: (each at: 2) put: each last]. ^keywordMap! ! !PMScanner class methodsFor: 'generated-comments' stamp: 'lr 12/9/2003 10:08'! scannerDefinitionComment " : [a] [n]? [A-Z] [a-zA-Z0-9]* ; : [a-zA-Z] [a-zA-Z0-9]* ; : [\-]? [0-9]+ (\. [0-9]+)? ; : \' [^\']* \' (\' [^\']* \')* ; : \: ; : \: ( \: )+ ; : [\~\-\!!\@\%\&\*\+\=\\\|\?\/\>\<\,] [\~\!!\@\%\&\*\+\=\\\|\?\/\>\<\,]? ; : \s+ ; : \$ . ; : . ;"! ! !PMScanner methodsFor: 'generated-scanner' stamp: 'lr 12/9/2003 10:08'! scan6 self recordMatch: #(17). self step. ((currentCharacter between: $A and: $Z) or: [currentCharacter between: $a and: $z]) ifTrue: [^self scan3]. ^self reportLastMatch! ! !PMScanner methodsFor: 'generated-tokens' stamp: 'lr 12/9/2003 10:08'! errorTokenId ^39! ! !PMScanner methodsFor: 'generated-scanner' stamp: 'lr 12/9/2003 10:08'! scan2 [ [self step. currentCharacter ~~ $'] whileTrue. self recordMatch: #(16). self step. currentCharacter == $'] whileTrue: []. ^self reportLastMatch! ! !PMScanner methodsFor: 'generated-scanner' stamp: 'lr 12/9/2003 10:08'! scan1 [self recordMatch: #(15). self step. currentCharacter isDigit] whileTrue. currentCharacter == $. ifTrue: [self step. currentCharacter isDigit ifTrue: [ [self recordMatch: #(15). self step. currentCharacter isDigit] whileTrue. ^self reportLastMatch]. ^self reportLastMatch]. ^self reportLastMatch! ! !PMScanner methodsFor: 'generated-scanner' stamp: 'lr 12/9/2003 10:08'! scan3 [self step. currentCharacter isDigit or: [(currentCharacter between: $A and: $Z) or: [currentCharacter between: $a and: $z]]] whileTrue. currentCharacter == $: ifTrue: [self recordMatch: #(18). self step. ((currentCharacter between: $A and: $Z) or: [currentCharacter between: $a and: $z]) ifTrue: [^self scan3]. ^self reportLastMatch]. ^self reportLastMatch! ! !PMScanner methodsFor: 'generated-scanner' stamp: 'lr 12/9/2003 10:08'! scanForToken self step. ((currentCharacter between: $A and: $Z) or: [(currentCharacter between: $b and: $h) or: [currentCharacter between: $j and: $z]]) ifTrue: [^self scan4]. (currentCharacter == $!! or: [(currentCharacter between: $% and: $&) or: [(currentCharacter between: $* and: $,) or: [currentCharacter == $/ or: [(currentCharacter between: $< and: $=) or: [(currentCharacter between: $? and: $@) or: [currentCharacter == $\ or: [currentCharacter == $~]]]]]]]) ifTrue: [self recordMatch: #(19). self step. (currentCharacter == $!! or: [(currentCharacter between: $% and: $&) or: [(currentCharacter between: $* and: $,) or: [currentCharacter == $/ or: [(currentCharacter between: $< and: $@) or: [currentCharacter == $\ or: [currentCharacter == $| or: [currentCharacter == $~]]]]]]]) ifTrue: [^self recordAndReportMatch: #(19)]. ^self reportLastMatch]. currentCharacter isDigit ifTrue: [^self scan1]. (currentCharacter isSeparator or: [currentCharacter == $ ]) ifTrue: [ [self recordMatch: #whitespace. self step. currentCharacter isSeparator or: [currentCharacter == $ ]] whileTrue. ^self reportLastMatch]. currentCharacter == $# ifTrue: [^self recordAndReportMatch: #(6)]. currentCharacter == $$ ifTrue: [self step. ^self recordAndReportMatch: #(21)]. currentCharacter == $' ifTrue: [^self scan2]. currentCharacter == $- ifTrue: [self recordMatch: #(19). self step. (currentCharacter == $!! or: [(currentCharacter between: $% and: $&) or: [(currentCharacter between: $* and: $,) or: [currentCharacter == $/ or: [(currentCharacter between: $< and: $@) or: [currentCharacter == $\ or: [currentCharacter == $| or: [currentCharacter == $~]]]]]]]) ifTrue: [^self recordAndReportMatch: #(19)]. currentCharacter isDigit ifTrue: [^self scan1]. ^self reportLastMatch]. currentCharacter == $. ifTrue: [^self recordAndReportMatch: #(12)]. currentCharacter == $: ifTrue: [^self recordAndReportMatch: #(10)]. currentCharacter == $> ifTrue: [self recordMatch: #(19). self step. (currentCharacter == $!! or: [(currentCharacter between: $% and: $&) or: [(currentCharacter between: $* and: $,) or: [currentCharacter == $/ or: [(currentCharacter between: $< and: $=) or: [(currentCharacter between: $? and: $@) or: [currentCharacter == $\ or: [currentCharacter == $| or: [currentCharacter == $~]]]]]]]]) ifTrue: [^self recordAndReportMatch: #(19)]. currentCharacter == $> ifTrue: [^self recordAndReportMatch: #(4 19)]. ^self reportLastMatch]. currentCharacter == $[ ifTrue: [^self recordAndReportMatch: #(8)]. currentCharacter == $a ifTrue: [self recordMatch: #(14). self step. (currentCharacter isDigit or: [(currentCharacter between: $a and: $m) or: [currentCharacter between: $o and: $z]]) ifTrue: [^self scan4]. (currentCharacter between: $A and: $Z) ifTrue: [^self scan5]. currentCharacter == $: ifTrue: [^self scan6]. currentCharacter == $n ifTrue: [self recordMatch: #(14). self step. (currentCharacter isDigit or: [currentCharacter between: $a and: $z]) ifTrue: [^self scan4]. (currentCharacter between: $A and: $Z) ifTrue: [^self scan5]. currentCharacter == $: ifTrue: [^self scan6]. ^self reportLastMatch]. ^self reportLastMatch]. currentCharacter == $i ifTrue: [self recordMatch: #(14). self step. (currentCharacter isDigit or: [(currentCharacter between: $A and: $Z) or: [(currentCharacter between: $a and: $e) or: [currentCharacter between: $g and: $z]]]) ifTrue: [^self scan4]. currentCharacter == $: ifTrue: [^self scan6]. currentCharacter == $f ifTrue: [self recordMatch: #(14). self step. (currentCharacter isDigit or: [(currentCharacter between: $A and: $Z) or: [currentCharacter between: $a and: $z]]) ifTrue: [^self scan4]. currentCharacter == $: ifTrue: [self recordMatch: #(2 17). self step. ((currentCharacter between: $A and: $Z) or: [currentCharacter between: $a and: $z]) ifTrue: [^self scan3]. ^self reportLastMatch]. ^self reportLastMatch]. ^self reportLastMatch]. currentCharacter == ${ ifTrue: [^self recordAndReportMatch: #(7)]. currentCharacter == $| ifTrue: [self recordMatch: #(9 19). self step. (currentCharacter == $!! or: [(currentCharacter between: $% and: $&) or: [(currentCharacter between: $* and: $,) or: [currentCharacter == $/ or: [(currentCharacter between: $< and: $@) or: [currentCharacter == $\ or: [currentCharacter == $| or: [currentCharacter == $~]]]]]]]) ifTrue: [^self recordAndReportMatch: #(19)]. ^self reportLastMatch]. currentCharacter == $} ifTrue: [^self recordAndReportMatch: #(11)]. ^self reportLastMatch! ! !PMScanner methodsFor: 'generated-tokens' stamp: 'lr 12/9/2003 10:08'! emptySymbolTokenId ^38! ! !PMScanner methodsFor: 'actions' stamp: 'lr 12/3/2003 22:36'! scanBackwardsFrom: aToken stream position: (0 max: aToken startPosition - 1). [ stream last isSeparator and: [ stream position > 0 ] ] whileTrue: [ stream position: stream position - 1 ].! ! !PMScanner methodsFor: 'generated-scanner' stamp: 'lr 12/9/2003 10:08'! scan4 [self recordMatch: #(14). self step. currentCharacter isDigit or: [(currentCharacter between: $A and: $Z) or: [currentCharacter between: $a and: $z]]] whileTrue. currentCharacter == $: ifTrue: [^self scan6]. ^self reportLastMatch! ! !UndefinedObject methodsFor: '*pattern' stamp: 'lr 12/3/2003 22:00'! acceptVisitor: aVisitor! ! Object subclass: #PMNode instanceVariableNames: 'parent ' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Core'! !PMNode methodsFor: 'accessing' stamp: 'lr 12/8/2003 19:12'! parent ^parent! ! PMNode subclass: #PMExpression instanceVariableNames: 'source node ' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Core'! !PMExpression methodsFor: 'accessing' stamp: 'lr 12/4/2003 17:35'! node ^node! ! !PMExpression methodsFor: 'accessing' stamp: 'lr 12/3/2003 21:56'! source: aString source _ aString! ! !PMExpression class methodsFor: 'instance creation' stamp: 'lr 12/4/2003 17:35'! source: aString node: aNode ^self new source: aString; node: aNode; yourself! ! !PMExpression methodsFor: 'accessing' stamp: 'lr 12/3/2003 21:56'! source ^source! ! !PMExpression methodsFor: 'comparing' stamp: 'lr 12/5/2003 21:51'! hash ^self node hash! ! !PMExpression methodsFor: 'accessing' stamp: 'lr 12/4/2003 17:38'! node: aNode node _ aNode! ! !PMExpression methodsFor: 'comparing' stamp: 'lr 12/5/2003 21:51'! = anObject ^self class = anObject class and: [ self node = anObject node ]! ! !PMExpression methodsFor: 'visiting' stamp: 'lr 12/3/2003 21:57'! acceptVisitor: aVisitor aVisitor visitExpression: self.! ! PMNode subclass: #PMCategory instanceVariableNames: 'name functions ' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Core'! !PMCategory methodsFor: 'private-building' stamp: 'lr 12/7/2003 20:29'! install PMBuilder visit: self! ! !PMCategory methodsFor: 'accessing' stamp: 'lr 12/5/2003 20:58'! groups | groups collection | groups _ OrderedCollection new. self functions do: [ :function | collection _ groups detect: [ :each | function selector = each first selector ] ifNone: [ groups add: OrderedCollection new ]. collection add: function ]. ^groups! ! !PMCategory methodsFor: 'private-building' stamp: 'lr 12/7/2003 20:30'! reinstall self uninstall; install! ! !PMCategory methodsFor: 'utility' stamp: 'lr 12/7/2003 21:28'! findLeastGeneralClass: aCollection | remainingClasses currentClass | remainingClasses _ aCollection asOrderedCollection. currentClass _ remainingClasses removeFirst. [ remainingClasses isEmpty ] whileFalse: [ [ remainingClasses first includesBehavior: currentClass ] whileFalse: [ currentClass _ currentClass superclass ]. remainingClasses removeFirst ]. ^currentClass! ! !PMCategory methodsFor: 'actions' stamp: 'lr 12/6/2003 13:55'! refresh | categoryName classes | categoryName _ self categoryName. classes _ Smalltalk allClasses select: [ :class | class organization categories includes: categoryName ]. functions _ classes inject: OrderedCollection new into: [ :result :class | result addAll: (PMFunction allFunctionsIn: self class: class); yourself ]! ! !PMCategory methodsFor: 'private' stamp: 'lr 12/6/2003 13:50'! name: aString name _ aString. self refresh.! ! !PMCategory methodsFor: 'private-building' stamp: 'lr 12/9/2003 10:38'! uninstall | categoryName | categoryName _ self categoryName. Smalltalk allClassesDo: [ :class | (class organization categories includes: categoryName) ifTrue: [ class removeCategory: categoryName ] ].! ! !PMCategory methodsFor: 'utility' stamp: 'lr 12/7/2003 21:42'! receiverClass: aCollection "Find the least general class to be the host of aCollection of functions." ^self findLeastGeneralClass: (aCollection collect: [ :each | each receiverClass ])! ! !PMCategory class methodsFor: 'instance creation' stamp: 'lr 12/4/2003 13:03'! name: aString ^self new name: aString; yourself! ! !PMCategory methodsFor: 'actions' stamp: 'lr 12/7/2003 20:31'! moveDown: aFunction | index | index _ functions indexOf: aFunction. (index between: 1 and: functions size - 1) ifTrue: [ self functions swap: index with: index + 1. self reinstall ]! ! !PMCategory methodsFor: 'comparing' stamp: 'lr 12/5/2003 21:13'! hash ^name hash! ! !PMCategory methodsFor: 'accessing' stamp: 'lr 12/4/2003 13:02'! name ^name! ! !PMCategory class methodsFor: 'private' stamp: 'lr 12/7/2003 20:09'! categoryPostfix ^'-Functional'! ! !PMCategory methodsFor: 'accessing' stamp: 'lr 12/5/2003 20:43'! functions ^functions! ! !PMCategory methodsFor: 'comparing' stamp: 'lr 12/5/2003 21:14'! = anObject ^self class = anObject class and: [ self name = anObject name ]! ! !PMCategory methodsFor: 'actions' stamp: 'lr 12/7/2003 20:31'! moveUp: aFunction | index | index _ functions indexOf: aFunction. (index between: 2 and: functions size) ifTrue: [ self functions swap: index with: index - 1. self reinstall ]! ! !PMCategory methodsFor: 'actions' stamp: 'lr 12/8/2003 22:08'! add: aFunction | 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.! ! !PMCategory methodsFor: 'actions' stamp: 'lr 12/8/2003 22:08'! remove: aFunction self functions remove: aFunction. self reinstall.! ! !PMCategory methodsFor: 'actions' stamp: 'lr 12/9/2003 10:37'! renameTo: aString | oldCategoryName newCategoryName | oldCategoryName _ self categoryName. self name: aString. newCategoryName _ self categoryName. Smalltalk allClassesDo: [ :class | (class organization categories includes: oldCategoryName) ifTrue: [ class organization renameCategory: oldCategoryName toBe: newCategoryName ] ].! ! !PMCategory methodsFor: 'visiting' stamp: 'lr 12/2/2003 19:12'! acceptVisitor: aVisitor aVisitor visitCategory: self! ! !PMCategory class methodsFor: 'accessing' stamp: 'lr 12/4/2003 13:13'! allCategories | categories | categories _ Smalltalk allClasses gather: [ :class | class organization categories select: [ :symbol | symbol endsWith: self categoryPostfix ] ]. ^categories asSet collect: [ :each | self name: (each copyFrom: self categoryPrefix size + 1 to: each size - self categoryPostfix size) ]! ! !PMCategory class methodsFor: 'private' stamp: 'lr 12/4/2003 13:12'! categoryPrefix ^'*'! ! !PMCategory methodsFor: 'accessing' stamp: 'lr 12/6/2003 13:22'! categoryName ^String streamContents: [ :stream | stream nextPutAll: self class categoryPrefix; nextPutAll: self name; nextPutAll: self class categoryPostfix ]! ! !PMCategory methodsFor: 'actions' stamp: 'lr 12/8/2003 22:09'! removeAll self uninstall; refresh ! ! PMNode subclass: #PMPattern instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Core'! !PMPattern methodsFor: 'tools' stamp: 'lr 12/2/2003 19:56'! receiverClass self subclassResponsibility! ! !PMPattern methodsFor: 'visiting' stamp: 'lr 12/1/2003 23:13'! acceptVisitor: aVisitor aVisitor visitPattern: self! ! PMPattern subclass: #PMVariablePattern instanceVariableNames: 'name ' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Core'! !PMVariablePattern methodsFor: 'comparing' stamp: 'lr 12/5/2003 22:40'! hash ^self class hash! ! !PMVariablePattern methodsFor: 'accessing' stamp: 'lr 12/1/2003 21:41'! name: aString name _ aString! ! !PMVariablePattern methodsFor: 'comparing' stamp: 'lr 12/5/2003 22:40'! = anObject ^self class = anObject class! ! !PMVariablePattern class methodsFor: 'instance-creation' stamp: 'lr 12/1/2003 21:43'! name: aString ^self new name: aString; yourself! ! !PMVariablePattern methodsFor: 'accessing' stamp: 'lr 12/1/2003 21:41'! name ^name! ! !PMVariablePattern methodsFor: 'tools' stamp: 'lr 12/2/2003 19:56'! receiverClass ^Object! ! !PMVariablePattern methodsFor: 'visiting' stamp: 'lr 12/1/2003 23:14'! acceptVisitor: aVisitor aVisitor visitVariablePattern: self! ! PMVariablePattern subclass: #PMBlockPattern instanceVariableNames: 'expression ' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Core'! !PMBlockPattern methodsFor: 'accessing' stamp: 'lr 12/8/2003 19:16'! expression: anExpression anExpression parent: self. expression _ anExpression.! ! !PMBlockPattern methodsFor: 'visiting' stamp: 'lr 12/4/2003 10:18'! acceptVisitor: aVisitor aVisitor visitBlockPattern: self! ! !PMBlockPattern class methodsFor: 'instance-creation' stamp: 'lr 12/4/2003 10:21'! name: aString expression: aNode ^(self name: aString) expression: aNode; yourself! ! !PMBlockPattern methodsFor: 'comparing' stamp: 'lr 12/5/2003 22:42'! hash ^self expression hash! ! !PMBlockPattern methodsFor: 'accessing' stamp: 'lr 12/4/2003 10:17'! expression ^expression! ! !PMBlockPattern methodsFor: 'comparing' stamp: 'lr 12/5/2003 22:41'! = anObject ^self class = anObject class and: [ self expression = anObject expression ]! ! PMVariablePattern subclass: #PMClassPattern instanceVariableNames: 'target ' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Core'! !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: 'tools' stamp: 'lr 12/5/2003 21:09'! receiverClass ^self target! ! !PMClassPattern methodsFor: 'accessing' stamp: 'lr 12/5/2003 21:08'! target: aClass target _ aClass! ! !PMClassPattern methodsFor: 'comparing' stamp: 'lr 12/5/2003 22:40'! = anObject ^self class = anObject class and: [ self target = anObject target ]! ! !PMClassPattern methodsFor: 'accessing' stamp: 'lr 12/5/2003 21:07'! target ^target! ! !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 ])! ! PMPattern subclass: #PMListPattern instanceVariableNames: 'items ' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Core'! !PMListPattern class methodsFor: 'instance-creation' stamp: 'lr 12/8/2003 18:32'! empty ^self new! ! !PMListPattern methodsFor: 'accessing-items' stamp: 'lr 12/8/2003 18:31'! addAll: aCollection aCollection do: [ :each | self add: each ]! ! !PMListPattern methodsFor: 'comparing' stamp: 'lr 12/8/2003 18:19'! = anObject ^self class = anObject class 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 20:49'! size ^items size! ! !PMListPattern methodsFor: 'comparing' stamp: 'lr 12/8/2003 18:20'! hash ^self items hash! ! !PMListPattern methodsFor: 'tools' stamp: 'lr 12/2/2003 19:56'! receiverClass ^SequenceableCollection! ! !PMListPattern methodsFor: 'testing' stamp: 'lr 12/8/2003 18:20'! isEmpty ^items isEmpty! ! !PMListPattern methodsFor: 'initialization' stamp: 'lr 12/8/2003 18:31'! initialize super initialize. items _ OrderedCollection new.! ! PMListPattern subclass: #PMOpenListPattern instanceVariableNames: 'tail ' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Core'! !PMOpenListPattern methodsFor: 'testing' stamp: 'lr 12/8/2003 22:41'! hasTail ^true! ! !PMOpenListPattern methodsFor: 'comparing' stamp: 'lr 12/8/2003 18:32'! hash ^super hash bitXor: [ self tail ]! ! !PMOpenListPattern class methodsFor: 'instance-creation' stamp: 'lr 12/8/2003 18:35'! head: aCollection tail: aPattern ^(self head: aCollection) tail: aPattern; yourself! ! !PMOpenListPattern methodsFor: 'accessing' stamp: 'lr 12/8/2003 19:11'! tail: aPattern aPattern parent: self. tail _ aPattern.! ! !PMOpenListPattern methodsFor: 'accessing' stamp: 'lr 12/8/2003 18:22'! tail ^tail! ! !PMOpenListPattern methodsFor: 'visiting' stamp: 'lr 12/8/2003 18:25'! acceptVisitor: aVisitor aVisitor visitOpenListPattern: self! ! !PMOpenListPattern methodsFor: 'comparing' stamp: 'lr 12/8/2003 22:50'! = anObject ^super = anObject and: [ self tail = anObject tail ]! ! !PMListPattern class methodsFor: 'instance-creation' stamp: 'lr 12/8/2003 18:35'! head: aCollection ^self empty addAll: aCollection; yourself! ! !PMListPattern methodsFor: 'accessing' stamp: 'lr 12/8/2003 18:19'! items: aCollection items _ aCollection! ! !PMListPattern methodsFor: 'testing' stamp: 'lr 12/8/2003 22:41'! hasTail ^false! ! !PMListPattern methodsFor: 'accessing' stamp: 'lr 12/8/2003 18:19'! items ^items! ! !PMListPattern methodsFor: 'accessing-items' stamp: 'lr 12/8/2003 19:10'! add: aPattern aPattern parent: self. items addLast: aPattern.! ! PMPattern subclass: #PMObjectPattern instanceVariableNames: 'object ' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Core'! !PMObjectPattern methodsFor: 'comparing' stamp: 'lr 12/5/2003 21:16'! = anObject ^self class = anObject class and: [ self object = anObject object ]! ! !PMObjectPattern methodsFor: 'visiting' stamp: 'lr 12/1/2003 23:14'! acceptVisitor: aVisitor aVisitor visitObjectPattern: self! ! !PMObjectPattern methodsFor: 'testing' stamp: 'lr 12/8/2003 20:44'! isLiteral ^self object class ~= String and: [ self object isLiteral or: [ self object isKindOf: Boolean ] ]! ! !PMObjectPattern class methodsFor: 'instance creation' stamp: 'lr 12/1/2003 21:15'! object: anObject ^self new object: anObject yourself! ! !PMObjectPattern methodsFor: 'accessing' stamp: 'lr 12/1/2003 19:48'! object ^object! ! !PMObjectPattern methodsFor: 'tools' stamp: 'lr 12/2/2003 19:56'! receiverClass ^self object class! ! !PMObjectPattern methodsFor: 'comparing' stamp: 'lr 12/5/2003 21:16'! hash ^self object hash! ! !PMObjectPattern methodsFor: 'accessing' stamp: 'lr 12/1/2003 19:47'! object: anObject object _ anObject! ! !PMPattern methodsFor: 'testing' stamp: 'lr 12/4/2003 17:15'! hasName ^self name notNil! ! !PMPattern methodsFor: 'tools' stamp: 'lr 12/4/2003 17:16'! name ^nil! ! !PMNode methodsFor: 'initialization' stamp: 'lr 12/2/2003 08:39'! initialize ! ! PMNode subclass: #PMSelector instanceVariableNames: 'selector ' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Core'! !PMSelector methodsFor: 'comparing' stamp: 'lr 12/5/2003 21:18'! hash ^self selector hash! ! !PMSelector methodsFor: 'testing' stamp: 'lr 12/2/2003 19:33'! isMatched ^false! ! !PMSelector class methodsFor: 'instance creation' stamp: 'lr 12/2/2003 08:49'! selector: aSymbol ^self new selector: aSymbol; yourself! ! !PMSelector methodsFor: 'visiting' stamp: 'lr 12/2/2003 08:58'! acceptVisitor: aVisitor aVisitor visitSelector: self! ! !PMSelector methodsFor: 'comparing' stamp: 'lr 12/5/2003 21:18'! = anObject ^self class = anObject class and: [ self selector = anObject selector ]! ! !PMSelector methodsFor: 'accessing' stamp: 'lr 12/2/2003 08:43'! selector: aSymbol selector _ aSymbol! ! PMSelector subclass: #PMMatchedSelector instanceVariableNames: 'pattern ' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Core'! !PMMatchedSelector methodsFor: 'visiting' stamp: 'lr 12/2/2003 09:13'! acceptVisitor: aVisitor aVisitor visitMatchedSelector: self! ! !PMMatchedSelector methodsFor: 'testing' stamp: 'lr 12/2/2003 19:34'! isMatched ^true! ! !PMMatchedSelector class methodsFor: 'instance creation' stamp: 'lr 12/2/2003 08:55'! selector: aSymbol pattern: aPattern ^(self selector: aSymbol) pattern: aPattern; yourself! ! !PMMatchedSelector methodsFor: 'comparing' stamp: 'lr 12/5/2003 21:19'! = anObject ^self class = anObject class and: [ self selector = anObject selector ] and: [ self pattern = anObject pattern ]! ! !PMMatchedSelector methodsFor: 'comparing' stamp: 'lr 12/5/2003 21:19'! hash ^self selector hash bitXor: self pattern hash! ! !PMMatchedSelector methodsFor: 'accessing' stamp: 'lr 12/8/2003 19:17'! pattern: aPattern aPattern parent: self. pattern _ aPattern.! ! !PMMatchedSelector methodsFor: 'accessing' stamp: 'lr 12/2/2003 08:51'! pattern ^pattern! ! !PMSelector methodsFor: 'accessing' stamp: 'lr 12/2/2003 08:43'! selector ^selector! ! PMNode subclass: #PMFunction instanceVariableNames: 'receiver arguments condition body ' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Core'! !PMFunction methodsFor: 'testing' stamp: 'lr 12/2/2003 09:27'! hasCondition ^condition notNil! ! !PMFunction methodsFor: 'utility' stamp: 'lr 12/2/2003 19:57'! receiverClass ^self receiver receiverClass! ! !PMFunction methodsFor: 'private' stamp: 'lr 12/8/2003 19:14'! receiver: aPattern aPattern parent: self. receiver _ aPattern.! ! !PMFunction methodsFor: 'accessing' stamp: 'lr 12/2/2003 10:14'! condition ^condition! ! !PMFunction methodsFor: 'printing' stamp: 'lr 12/4/2003 10:13'! asText ^Text streamContents: [ :stream | PMFunctionPrinter print: self on: stream ]! ! !PMFunction methodsFor: 'printing' stamp: 'lr 12/4/2003 10:02'! printOn: aStream PMSelectorPrinter print: self on: aStream! ! !PMFunction methodsFor: 'testing' stamp: 'lr 12/2/2003 19:32'! hasBody ^body notNil! ! !PMFunction class methodsFor: 'configuration' stamp: 'lr 12/4/2003 20:40'! argumentPrefix ^'t'! ! !PMFunction methodsFor: 'utility' stamp: 'lr 12/5/2003 00:07'! numArgs ^self hasArguments ifTrue: [ arguments size ] ifFalse: [ 0 ]! ! !PMFunction class methodsFor: 'instance creation' stamp: 'lr 12/8/2003 19:23'! receiver: aPattern arguments: aCollection body: aBodyNode ^self new receiver: aPattern; arguments: aCollection; body: aBodyNode; fixArgumentNames; yourself! ! !PMFunction methodsFor: 'accessing' stamp: 'lr 12/1/2003 20:14'! body ^body! ! !PMFunction methodsFor: 'private' stamp: 'lr 12/8/2003 19:16'! arguments: aCollection aCollection collect: [ :each | each parent: self ]. arguments _ aCollection.! ! !PMFunction methodsFor: 'printing' stamp: 'lr 12/4/2003 10:13'! asString ^String streamContents: [ :stream | PMFunctionPrinter print: self on: stream ]! ! !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: 'private' stamp: 'lr 12/8/2003 19:14'! condition: anExpression anExpression parent: self. condition _ anExpression.! ! !PMFunction class methodsFor: 'instance creation' stamp: 'lr 12/4/2003 17:07'! receiver: aPattern arguments: aCollection condition: aConditionNode body: aBodyNode ^self new receiver: aPattern; arguments: aCollection; condition: aConditionNode; body: aBodyNode; fixArgumentNames; yourself! ! !PMFunction methodsFor: 'comparing' stamp: 'lr 12/5/2003 21:50'! hash ^receiver hash bitXor: (arguments hash bitXor: condition hash)! ! !PMFunction class methodsFor: 'accessing' stamp: 'lr 12/6/2003 16:39'! allFunctionsIn: aCategory class: aClass | result selectors source parsed function | result _ OrderedCollection new. selectors _ aClass organization listAtCategoryNamed: aCategory categoryName. selectors do: [ :selector | source _ aClass sourceCodeAt: selector ifAbsent: [ String new ]. source notNil ifTrue: [ parsed _ RBParser parseMethod: source onError: [ :string :position | nil ]. parsed notNil ifTrue: [ function _ String new. parsed comments do: [ :interval | function _ function , (parsed source copyFrom: interval first + 1 to: interval last). (parsed source at: interval last + 1) = $" ifFalse: [ result add: (PMParser parse: function allButLast). function _ String new ] ] ] ] ]. ^result! ! !PMFunction methodsFor: 'private' stamp: 'lr 12/9/2003 18:32'! fixArgumentNames PMArgumentMapper visit: self! ! !PMFunction methodsFor: 'testing' stamp: 'lr 12/2/2003 19:34'! hasArguments ^arguments first isMatched! ! !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: 'accessing' stamp: 'lr 12/2/2003 19:56'! receiver ^receiver! ! !PMFunction class methodsFor: 'configuration' stamp: 'lr 12/9/2003 20:36'! template ^PMParser parse: 'receiverPattern>>selector: argumentPattern if: [ condition statements ] "comment stating purpose of function" | temporary variable names | statements'! ! !PMFunction methodsFor: 'private' stamp: 'lr 12/8/2003 19:15'! body: anExpression anExpression parent: self. body _ anExpression.! ! !PMFunction methodsFor: 'visiting' stamp: 'lr 12/2/2003 19:32'! acceptVisitor: aVisitor aVisitor visitFunction: self! ! !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: '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 ]! ! !PMNode class methodsFor: 'instance creation' stamp: 'lr 12/2/2003 08:39'! new ^super new initialize; yourself! ! !PMNode methodsFor: 'visiting' stamp: 'lr 12/2/2003 08:40'! acceptVisitor: aVisitor self subclassResponsibility! ! !PMNode methodsFor: 'accessing' stamp: 'lr 12/8/2003 19:12'! parent: aNode parent _ aNode! ! Object subclass: #PMMock instanceVariableNames: 'message ' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Tests'! !PMMock methodsFor: 'private' stamp: 'lr 12/7/2003 20:13'! doesNotUnderstand: aMessage message _ aMessage! ! !PMMock methodsFor: 'accessing' stamp: 'lr 12/7/2003 20:13'! message ^message! ! Object subclass: #PMVisitor instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Visitor'! !PMVisitor methodsFor: 'visiting' stamp: 'lr 12/2/2003 19:13'! visitCategory: aCategory self visitAll: aCategory functions! ! !PMVisitor class methodsFor: 'instance creation' stamp: 'lr 12/1/2003 23:16'! new ^super new initialize; yourself! ! PMVisitor subclass: #PMBuilder instanceVariableNames: 'receiverClass methodNode category function ' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Visitor'! !PMBuilder methodsFor: 'building' stamp: 'lr 12/5/2003 22:18'! buildFunctionBody ^RBBlockNode body: (self buildFunctionBlock)! ! !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: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/5/2003 22:24'! buildMethodNode methodNode _ RBMethodNode selector: function selector arguments: (self buildMethodArguments) body: (RBSequenceNode statements: OrderedCollection new). ^methodNode comments: OrderedCollection new; source: String new; yourself! ! !PMBuilder methodsFor: 'building' stamp: 'lr 12/8/2003 22:45'! buildFunctionMatcher ^(PMConditionBuilder visit: function) condition! ! !PMBuilder methodsFor: 'building' stamp: 'lr 12/6/2003 15:24'! buildMethod: aCollection self buildMethodNode. self visitAll: aCollection. self buildMethodEnd. receiverClass compile: methodNode formattedCode. receiverClass organization classify: function selector under: category categoryName.! ! !PMBuilder methodsFor: 'visiting' stamp: 'lr 12/6/2003 15:23'! visitCategory: aCategory category _ aCategory. category groups do: [ :group | function _ group first. receiverClass _ aCategory receiverClass: group. self buildMethod: group ]! ! !PMBuilder methodsFor: 'building' stamp: 'lr 12/5/2003 22:16'! buildMethodArguments ^function argumentNames collect: [ :each | RBVariableNode named: each ]! ! !PMBuilder methodsFor: 'building' stamp: 'lr 12/6/2003 16:32'! buildMethodEnd methodNode addNode: (RBReturnNode value: (RBMessageNode receiver: (RBVariableNode named: 'self') selector: #doesNotUnderstand: arguments: {RBMessageNode receiver: (RBVariableNode named: 'Message') selector: #selector:arguments: arguments: { RBLiteralNode value: function selector. RBArrayNode leftBrace: nil rightBrace: nil statements: (self buildMethodArguments) }})); removeDeadCode. methodNode body nodesDo: [ :each | each comments: nil ].! ! !PMBuilder methodsFor: 'visiting' stamp: 'lr 12/5/2003 22:21'! visitFunction: aFunction function _ aFunction. methodNode addNode: self buildFunction! ! !PMVisitor methodsFor: 'visiting' stamp: 'lr 12/8/2003 18:48'! visitListPattern: aPattern self visitPattern: aPattern. self visitAll: aPattern items.! ! !PMVisitor methodsFor: 'visiting' stamp: 'lr 12/2/2003 09:06'! visitSelector: aSelector! ! PMVisitor subclass: #PMPrinter instanceVariableNames: 'stream ' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Visitor'! !PMPrinter methodsFor: 'accessing' stamp: 'lr 12/4/2003 10:03'! contents ^self stream contents! ! !PMPrinter class methodsFor: 'instance creation' stamp: 'lr 12/4/2003 10:02'! print: aNode on: aStream ^self new stream: aStream; visit: aNode; yourself! ! !PMPrinter methodsFor: 'private' stamp: 'lr 12/4/2003 10:02'! stream: aStream stream _ aStream! ! PMPrinter subclass: #PMSelectorPrinter instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Visitor'! !PMSelectorPrinter methodsFor: 'visiting' stamp: 'lr 12/2/2003 09:13'! visitMatchedSelector: aSelector stream nextPutAll: aSelector selector; space. self visit: aSelector pattern.! ! PMSelectorPrinter subclass: #PMFunctionPrinter instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Visitor'! !PMFunctionPrinter methodsFor: 'visiting' stamp: 'lr 12/4/2003 10:07'! visitFunction: aFunction stream withAttribute: TextEmphasis bold do: [ super visitFunction: aFunction ]. aFunction hasCondition ifTrue: [ stream withAttribute: TextEmphasis italic do: [ stream cr; tab; nextPutAll: 'if: ['. self visit: aFunction condition. stream nextPut: $] ] ]. self visit: aFunction body.! ! !PMSelectorPrinter methodsFor: 'visiting' stamp: 'lr 12/8/2003 19:20'! visitListPattern: aPattern stream nextPut: ${. self visitAll: aPattern items separatedBy: [ stream nextPutAll: '. ' ]. stream nextPut: $}.! ! !PMSelectorPrinter methodsFor: 'visiting' stamp: 'lr 12/3/2003 22:02'! visitSelector: aSelector stream nextPutAll: aSelector selector.! ! !PMSelectorPrinter methodsFor: 'visiting' stamp: 'lr 12/4/2003 10:37'! visitBlockPattern: aPattern stream nextPutAll: '[ :'. self visitVariablePattern: aPattern. stream nextPutAll: ' |'. self visit: aPattern expression. stream nextPut: $].! ! !PMSelectorPrinter methodsFor: 'visiting' stamp: 'lr 12/2/2003 09:16'! visitVariablePattern: aPattern stream nextPutAll: aPattern name.! ! !PMSelectorPrinter methodsFor: 'visiting' stamp: 'lr 12/8/2003 19:40'! visitOpenListPattern: aPattern self visitListPattern: aPattern. stream skip: -1; nextPut: $|. self visit: aPattern tail. stream nextPut: $}.! ! !PMSelectorPrinter methodsFor: 'visiting' stamp: 'lr 12/2/2003 09:15'! visitObjectPattern: aPattern stream print: aPattern object.! ! !PMSelectorPrinter methodsFor: 'visiting' stamp: 'lr 12/3/2003 22:02'! visitExpression: anExpression stream nextPutAll: anExpression source.! ! !PMSelectorPrinter methodsFor: 'visiting' stamp: 'lr 12/4/2003 10:06'! visitFunction: aFunction self visit: aFunction receiver. stream nextPutAll: '>>'. self visitAll: aFunction arguments separatedBy: [ stream space ].! ! !PMPrinter methodsFor: 'private' stamp: 'lr 12/4/2003 10:03'! stream ^stream! ! !PMVisitor methodsFor: 'visiting' stamp: 'lr 12/4/2003 17:14'! visitPattern: aPattern! ! !PMVisitor methodsFor: 'initialization' stamp: 'lr 12/1/2003 23:16'! initialize ! ! !PMVisitor class methodsFor: 'instance creation' stamp: 'lr 12/2/2003 19:10'! visit: aNode ^self new visit: aNode; yourself! ! !PMVisitor methodsFor: 'visiting' stamp: 'lr 12/3/2003 21:59'! visitExpression: anExpression! ! !PMVisitor methodsFor: 'visiting' stamp: 'lr 12/1/2003 23:11'! visitClassPattern: aPattern self visitVariablePattern: aPattern.! ! !PMVisitor methodsFor: 'utility' stamp: 'lr 12/1/2003 23:12'! visitAll: aCollection aCollection do: [ :each | each acceptVisitor: self ].! ! !PMVisitor methodsFor: 'visiting' stamp: 'lr 12/4/2003 10:25'! visitBlockPattern: aPattern self visitVariablePattern: aPattern.! ! !PMVisitor methodsFor: 'utility' stamp: 'lr 12/1/2003 23:18'! visitAll: aCollection separatedBy: aBlock aCollection do: [ :each | each acceptVisitor: self ] separatedBy: aBlock! ! !PMVisitor methodsFor: 'visiting' stamp: 'lr 12/8/2003 18:48'! visitOpenListPattern: aPattern self visitListPattern: aPattern. self visit: aPattern tail.! ! !PMVisitor methodsFor: 'visiting' stamp: 'lr 12/2/2003 09:06'! visitVariablePattern: aPattern self visitPattern: aPattern.! ! PMVisitor subclass: #PMStackedVisitor instanceVariableNames: 'stack ' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Visitor'! PMStackedVisitor subclass: #PMArgumentMapper instanceVariableNames: 'mapping expressions ' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Visitor'! !PMArgumentMapper methodsFor: 'private' stamp: 'lr 12/8/2003 20:06'! applyMapping | rewriter | mapping keysAndValuesDo: [ :source :target | rewriter _ ParseTreeRewriter new. rewriter replaceTree: source withTree: target. expressions do: [ :each | rewriter executeTree: each node ] ]! ! !PMArgumentMapper methodsFor: 'visiting' stamp: 'lr 12/8/2003 22:37'! visitOpenListPattern: aPattern self visitListPattern: aPattern. super visitOpenListPattern: aPattern. ! ! !PMArgumentMapper methodsFor: 'visiting' stamp: 'lr 12/8/2003 22:16'! visitFunction: aFunction super visitFunction: aFunction. self visit: aFunction condition. self visit: aFunction body. self applyMapping.! ! !PMArgumentMapper methodsFor: 'visiting' stamp: 'lr 12/8/2003 21:25'! visitVariablePattern: aPattern self defineMapping: aPattern name! ! !PMArgumentMapper methodsFor: 'visiting' stamp: 'lr 12/8/2003 20:00'! visitBlockPattern: aPattern self visitVariablePattern: aPattern. self visit: aPattern expression.! ! !PMArgumentMapper methodsFor: 'visiting' stamp: 'lr 12/8/2003 20:15'! visitExpression: anExpression expressions add: anExpression! ! !PMArgumentMapper methodsFor: 'accessing' stamp: 'lr 12/4/2003 22:37'! mapping ^mapping! ! !PMArgumentMapper methodsFor: 'private' stamp: 'lr 12/8/2003 21:30'! defineMapping: aString | key | key _ RBVariableNode named: aString. (mapping includesKey: key) ifTrue: [ ^self error: aString , ' is already defined' ]. ^mapping at: key put: self top! ! !PMArgumentMapper methodsFor: 'initialization' stamp: 'lr 12/8/2003 20:19'! initialize super initialize. mapping _ Dictionary new. expressions _ OrderedCollection new.! ! !PMStackedVisitor methodsFor: 'visiting' stamp: 'lr 12/8/2003 22:35'! visitListPattern: aPattern aPattern items withIndexDo: [ :each :pos | self pushSelector: #at: argument: pos do: [ self visit: each ] ]! ! !PMStackedVisitor methodsFor: 'private' stamp: 'lr 12/8/2003 22:58'! pushSelector: aSymbol argument: aValue do: aBlock self push: (RBMessageNode receiver: self top selector: aSymbol arguments: {RBLiteralNode value: aValue}) do: aBlock ! ! !PMStackedVisitor methodsFor: 'utility' stamp: 'lr 12/8/2003 22:13'! removeAll stack _ OrderedCollection new.! ! !PMStackedVisitor methodsFor: 'initialization' stamp: 'lr 12/8/2003 22:13'! initialize super initialize. self removeAll.! ! !PMStackedVisitor methodsFor: 'utility' stamp: 'lr 12/8/2003 21:53'! top ^stack last copy! ! PMStackedVisitor subclass: #PMConditionBuilder instanceVariableNames: 'conditions ' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Visitor'! !PMConditionBuilder methodsFor: 'utility' stamp: 'lr 12/8/2003 23:06'! addNode: aNode conditions addLast: aNode! ! !PMConditionBuilder methodsFor: 'visiting' stamp: 'lr 12/8/2003 22:33'! visitClassPattern: aPattern self addSelector: #isKindOf: argument: aPattern target! ! !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: 'visiting' stamp: 'lr 12/8/2003 22:40'! visitListPattern: aPattern self addSelector: #isKindOf: argument: aPattern receiverClass. self pushSelector: #size do: [ self addSelector: (aPattern hasTail ifTrue: [ #>= ] ifFalse: [ #== ]) argument: aPattern size ]. super visitListPattern: aPattern.! ! !PMConditionBuilder methodsFor: 'visiting' stamp: 'lr 12/8/2003 23:08'! visitFunction: aFunction super visitFunction: aFunction. self visit: aFunction condition.! ! !PMConditionBuilder methodsFor: 'utility' stamp: 'lr 12/8/2003 23:06'! addSelector: aSymbol self addNode: (RBMessageNode receiver: self top selector: aSymbol)! ! !PMConditionBuilder methodsFor: 'visiting' stamp: 'lr 12/8/2003 22:42'! visitOpenListPattern: aPattern self visitListPattern: aPattern. super visitOpenListPattern: aPattern.! ! !PMConditionBuilder methodsFor: 'visiting' stamp: 'lr 12/8/2003 22:28'! visitExpression: anExpression self addNode: anExpression node! ! !PMConditionBuilder methodsFor: 'visiting' stamp: 'lr 12/8/2003 22:33'! visitObjectPattern: aPattern self addSelector: (aPattern isLiteral ifTrue: [ #== ] ifFalse: [ #= ]) argument: aPattern object! ! !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: 'visiting' stamp: 'lr 12/8/2003 22:24'! visitBlockPattern: aPattern self visit: aPattern expression! ! !PMConditionBuilder methodsFor: 'initialization' stamp: 'lr 12/4/2003 22:50'! initialize super initialize. conditions _ OrderedCollection new.! ! !PMStackedVisitor methodsFor: 'visiting' stamp: 'lr 12/8/2003 22:16'! visitFunction: aFunction self initialize. self pushVariable: 'self' do: [ self visit: aFunction receiver ]. aFunction arguments withIndexDo: [ :each :index | self pushVariable: 't' , index asString do: [ self visit: each ] ].! ! !PMStackedVisitor methodsFor: 'private' stamp: 'lr 12/8/2003 22:14'! pushVariable: aString do: aBlock self push: (RBVariableNode named: aString) do: aBlock ! ! !PMStackedVisitor methodsFor: 'utility' stamp: 'lr 12/8/2003 20:19'! push: anObject do: aBlock stack addLast: anObject. aBlock ensure: [ stack removeLast ].! ! !PMStackedVisitor methodsFor: 'private' stamp: 'lr 12/8/2003 22:14'! pushSelector: aSymbol do: aBlock self push: (RBMessageNode receiver: self top selector: aSymbol) do: aBlock ! ! !PMStackedVisitor methodsFor: 'visiting' stamp: 'lr 12/8/2003 22:36'! visitOpenListPattern: aPattern self pushSelector: #allButFirst: argument: aPattern size do: [ self visit: aPattern tail ]! ! !PMVisitor methodsFor: 'utility' stamp: 'lr 12/1/2003 23:12'! visit: anObject anObject acceptVisitor: self.! ! !PMVisitor methodsFor: 'visiting' stamp: 'lr 12/2/2003 09:05'! visitObjectPattern: aPattern self visitPattern: aPattern.! ! !PMVisitor methodsFor: 'visiting' stamp: 'lr 12/3/2003 21:59'! visitFunction: aFunction self visit: aFunction receiver. self visitAll: aFunction arguments. self visit: aFunction condition. self visit: aFunction body.! ! !PMVisitor methodsFor: 'visiting' stamp: 'lr 12/2/2003 09:13'! visitMatchedSelector: aSelector self visitSelector: aSelector. self visit: aSelector pattern.! ! !SequenceableCollection methodsFor: '*Pattern-Examples-Functional' stamp: 'lr 12/9/2003 19:58'! len "{}>>len ""#(1 2 3 4) len"" ^0" "{x|xs}>>len ^1 + xs len" ((self isKindOf: SequenceableCollection) and: [(self size == 0)]) ifTrue: [^0]. ((self isKindOf: SequenceableCollection) and: [(self size >= 1)]) ifTrue: [^1 + (self allButFirst: 1) len]. ^self doesNotUnderstand: (Message selector: #len arguments: { })! ! !SequenceableCollection methodsFor: '*Pattern-Examples-Functional' stamp: 'lr 12/9/2003 19:58'! zip: t1 "aSequenceableCollection>>zip: {} ""#(1 2 3 4) zip: #(a b c d)"" ^Array new" "{}>>zip: aSequenceableCollection ^Array new" "{x|xs}>>zip: {y|ys} ^(Array with: x with: y) , (xs zip: ys)" (((self isKindOf: SequenceableCollection) and: [(t1 isKindOf: SequenceableCollection)]) and: [(t1 size == 0)]) ifTrue: [^Array new]. (((self isKindOf: SequenceableCollection) and: [(self size == 0)]) and: [(t1 isKindOf: SequenceableCollection)]) ifTrue: [^Array new]. ((((self isKindOf: SequenceableCollection) and: [(self size >= 1)]) and: [(t1 isKindOf: SequenceableCollection)]) and: [(t1 size >= 1)]) ifTrue: [^(Array with: (self at: 1) with: (t1 at: 1)) , ((self allButFirst: 1) zip: (t1 allButFirst: 1))]. ^self doesNotUnderstand: (Message selector: #zip: arguments: { t1})! ! !SequenceableCollection methodsFor: '*Pattern-Examples-Functional' stamp: 'lr 12/9/2003 19:58'! fold: t1 into: t2 "{}>>fold: a into: aBlockContext ""#(1 2 3 4) fold: 0 into: [ :a :b | a + b ]"" ^a" "{x|xs}>>fold: a into: aBlockContext ^aBlockContext value: x value: (xs fold: a into: aBlockContext)" (((self isKindOf: SequenceableCollection) and: [(self size == 0)]) and: [(t2 isKindOf: BlockContext)]) ifTrue: [^t1]. (((self isKindOf: SequenceableCollection) and: [(self size >= 1)]) and: [(t2 isKindOf: BlockContext)]) ifTrue: [^t2 value: (self at: 1) value: ((self allButFirst: 1) fold: t1 into: t2)]. ^self doesNotUnderstand: (Message selector: #fold:into: arguments: { t1. t2})! ! !SequenceableCollection methodsFor: '*Pattern-Examples-Functional' stamp: 'lr 12/9/2003 19:58'! tail "{x|xs}>>tail ""#(1 2 3 4) tail"" ^xs" ((self isKindOf: SequenceableCollection) and: [(self size >= 1)]) ifTrue: [^self allButFirst: 1]. ^self doesNotUnderstand: (Message selector: #tail arguments: { })! ! !SequenceableCollection methodsFor: '*Pattern-Examples-Functional' stamp: 'lr 12/9/2003 19:58'! head "{x|xs}>>head ""#(1 2 3 4) head"" ^x" ((self isKindOf: SequenceableCollection) and: [(self size >= 1)]) ifTrue: [^self at: 1]. ^self doesNotUnderstand: (Message selector: #head arguments: { })! ! !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 12/9/2003 19:58'! map: t1 "{}>>map: aBlockContext ""(1 to: 10) map: [ :x | x fib ]"" ^Array new" "{x|xs}>>map: aBlockContext ^(Array with: (aBlockContext value: x)) , (xs map: aBlockContext)" (((self isKindOf: SequenceableCollection) and: [(self size == 0)]) and: [(t1 isKindOf: BlockContext)]) ifTrue: [^Array new]. (((self isKindOf: SequenceableCollection) and: [(self size >= 1)]) and: [(t1 isKindOf: BlockContext)]) ifTrue: [^(Array with: (t1 value: (self at: 1))) , ((self allButFirst: 1) map: t1)]. ^self doesNotUnderstand: (Message selector: #map: arguments: { t1})! ! MCTool subclass: #PMBrowser instanceVariableNames: 'categories categorySelection functionSelection textMorph source sourceSelection ' classVariableNames: '' poolDictionaries: '' category: 'Pattern-UI'! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 12/4/2003 13:08'! categoryList ^categories collect: [ :each | each name ]! ! !PMBrowser methodsFor: 'testing' stamp: 'lr 12/4/2003 14:07'! hasChanges self changed: #wantToChange. ^self canDiscardEdits not ! ! !PMBrowser methodsFor: 'actions' stamp: 'lr 12/6/2003 15:15'! 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 receiverClass: 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/6/2003 14:48'! buttonSpecs ^#( ('Refresh' refresh 'Refresh the view') ('Browse' browse 'Browse the selected function' hasSelectedCategory) ('Move Up' moveUpFunction 'Move the selected function upwards' hasSelectedFunction) ('Move Down' moveDownFunction 'Move the selected function downwards' hasSelectedFunction) )! ! !PMBrowser methodsFor: 'testing' stamp: 'lr 12/4/2003 11:21'! hasSelectedFunction ^self functionSelection isZero not! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 12/8/2003 22:10'! 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. self source: aString ]. self functionSelection: (self category functions indexOf: function) ]! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 12/4/2003 15:51'! categorySelection: aNumber self hasChanges ifFalse: [ categorySelection _ aNumber. self changed: #categoryList. self functionSelection: 0. aNumber isZero ifTrue: [ self source: String new ] ]! ! !PMBrowser methodsFor: 'actions' stamp: 'lr 12/8/2003 22:09'! removeCategory (PopUpMenu confirm: 'Are you sure you want to remove this category and all its functions?') ifTrue: [ self category removeAll. self refresh ].! ! !PMBrowser methodsFor: 'actions' stamp: 'lr 12/4/2003 17:44'! refresh categories _ PMCategory allCategories asSortedCollection: [ :x :y | x name < y name ]. self categorySelection: 0. self changed: #categoryList; changed: #functionList; changed: #sourceText.! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 12/4/2003 16:52'! functionSelection: aNumber self hasChanges ifFalse: [ aNumber isZero ifTrue: [ self addFunction. self selection: (1 to: source size) ] ifFalse: [ self source: (self category functions at: aNumber) asText. self selection: (1 to: 0) ]. functionSelection _ aNumber. self changed: #functionList ]! ! !PMBrowser methodsFor: 'testing' stamp: 'lr 12/4/2003 11:21'! hasSelectedCategory ^self categorySelection isZero not! ! !PMBrowser methodsFor: 'actions' stamp: 'lr 12/4/2003 16:53'! moveDownFunction functionSelection < self category functions size ifTrue: [ self category moveDown: self function. self functionSelection: functionSelection + 1 ]! ! !PMBrowser methodsFor: 'utility' stamp: 'lr 12/4/2003 15:02'! source: aString source _ aString. self changed: #sourceString.! ! !PMBrowser methodsFor: 'actions' stamp: 'lr 12/4/2003 14:47'! clearUserEditFlag self changed: #clearUserEdits.! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 12/4/2003 09:16'! defaultExtent ^650@400! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 12/4/2003 13:58'! sourceString ^source! ! !PMBrowser methodsFor: 'actions' stamp: 'lr 12/4/2003 15:01'! addFunction functionSelection _ 0. self source: PMFunction template asText. self selection: (1 to: source size). self changed: #functionSelection; changed: #sourceString.! ! !PMBrowser methodsFor: 'accessing' stamp: 'lr 12/4/2003 13:29'! category ^(categorySelection between: 1 and: categories size) ifTrue: [ categories at: categorySelection ] ifFalse: [ nil ]! ! !PMBrowser methodsFor: 'utility' stamp: 'lr 12/4/2003 15:18'! parseError: aString at: aNumber | errorString | errorString _ String streamContents: [ :stream | stream nextPutAll: (aString copyFrom: 19 to: aString size). stream nextPutAll: ' ->' ]. textMorph selectFrom: aNumber to: aNumber - 1. textMorph replaceSelectionWith: errorString.! ! !PMBrowser methodsFor: 'initialization' stamp: 'lr 12/4/2003 14:20'! initialize categories _ OrderedCollection new. categorySelection _ functionSelection _ 0. source _ String new. sourceSelection _ 1 to: 0.! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 12/4/2003 13:28'! categorySelection ^categorySelection! ! !PMBrowser methodsFor: 'actions' stamp: 'lr 12/8/2003 22:09'! removeFunction self category remove: self function. self changed: #functionList. self addFunction.! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 12/4/2003 15:12'! textMorph: aSelector ^textMorph _ PluggableTextMorph on: self text: (aSelector , 'String') asSymbol accept: (aSelector , 'String:') asSymbol readSelection: (aSelector , 'Selection') asSymbol menu: (aSelector , 'Menu:shifted:') asSymbol ! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 12/4/2003 11:23'! functionListMenu: aMenu ^aMenu add: 'add' target: self selector: #addFunction; add: 'remove' target: self selector: #removeFunction; addLine; add: 'move up' target: self selector: #moveUpFunction; add: 'move down' target: self selector: #moveDownFunction; yourself! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 12/4/2003 15:41'! functionList ^self hasSelectedCategory ifTrue: [ self category functions collect: [ :each | each printString ] ] ifFalse: [ Array new ]! ! !PMBrowser methodsFor: 'actions' stamp: 'lr 12/4/2003 13:39'! 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 categorySelection: index ].! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 12/4/2003 09:15'! defaultLabel ^'Function Browser'! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 12/4/2003 13:45'! functionSelection ^functionSelection! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 12/9/2003 20:42'! windowColor ^Color blue mixed: 0.5 with: Color white! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 12/4/2003 13:59'! sourceSelection ^sourceSelection! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 12/9/2003 20:38'! buildWindow ^super buildWindow paneColor: self windowColor; yourself! ! !PMBrowser methodsFor: 'actions' stamp: 'lr 12/4/2003 14:48'! renameCategory | result | 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: 'morphic ui' stamp: 'lr 12/4/2003 12:09'! sourceMenu: aMenu shifted: aBoolean ^StringHolder new codePaneMenu: aMenu shifted: aBoolean! ! !PMBrowser methodsFor: 'accessing' stamp: 'lr 12/4/2003 16:11'! function ^self hasSelectedFunction ifTrue: [ self category functions at: functionSelection ] ifFalse: [ nil ]! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 12/4/2003 14:42'! categoryListMenu: aMenu ^aMenu add: 'add...' target: self selector: #addCategory; add: 'rename...' target: self selector: #renameCategory; add: 'remove' target: self selector: #removeCategory; addLine; add: 'refresh' target: self selector: #refresh; yourself! ! !PMBrowser methodsFor: 'morphic ui' stamp: 'lr 12/4/2003 11:58'! widgetSpecs ^#( ((listMorph: category) (0 0 0.25 0.4) (0 0 0 -30)) ((listMorph: function) (0.25 0 1 0.4) (0 0 0 -30)) ((buttonRow) (0 0.4 1 0.4) (0 -30 0 0)) ((textMorph: source) (0 0.4 1 1)) )! ! !PMBrowser methodsFor: 'actions' stamp: 'lr 12/4/2003 16:52'! moveUpFunction functionSelection > 1 ifTrue: [ self category moveUp: self function. self functionSelection: functionSelection - 1 ]! ! !PMBrowser class methodsFor: 'instance creation' stamp: 'lr 12/9/2003 20:01'! open "self open" self new initialize; show; refresh! ! !Integer methodsFor: '*Pattern-Examples-Functional' stamp: 'lr 12/9/2003 19:58'! 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 isKindOf: Integer) and: [(self > 1)]) ifTrue: [^(self - 1) fib + (self - 2) fib]. ^self doesNotUnderstand: (Message selector: #fib arguments: { })! ! TestCase subclass: #PMFunctionalTest instanceVariableNames: 'function ' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Tests'! PMFunctionalTest subclass: #PMVisitorTest instanceVariableNames: 'mapping ' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Tests'! !PMVisitorTest methodsFor: 'utility' stamp: 'lr 12/8/2003 21:34'! mappingOf: aString mapping _ Dictionary new. function _ self parse: aString. (PMArgumentMapper visit: function) mapping keysAndValuesDo: [ :key :value | mapping at: key formattedCode put: value formattedCode ]! ! !PMVisitorTest methodsFor: 'testing-arguments' stamp: 'lr 12/8/2003 21:59'! testObjectArgument self mappingOf: '0>>foo: true'. self assert: mapping size = 0. self mappingOf: '0>>foo: 123'. self assert: mapping size = 0. self mappingOf: '0>>foo: a'. self assert: mapping size = 1. self assert: (mapping at: 'a') = 't1'. self mappingOf: '0>>foo: [ :a | a isFoo ]'. self assert: mapping size = 1. self assert: (mapping at: 'a') = 't1'. self mappingOf: '0>>foo: anAssociation'. self assert: mapping size = 1. self assert: (mapping at: 'anAssociation') = 't1'.! ! !PMVisitorTest methodsFor: 'testing-arguments' stamp: 'lr 12/8/2003 21:55'! testOpenListArgument self mappingOf: '0>>foo: {x|xs}'. self assert: mapping size = 2. self assert: (mapping at: 'x') = 't1 at: 1'. self assert: (mapping at: 'xs') = 't1 allButFirst: 1'. self mappingOf: '0>>foo: {x. y|xs}'. self assert: mapping size = 3. self assert: (mapping at: 'x') = 't1 at: 1'. self assert: (mapping at: 'y') = 't1 at: 2'. self assert: (mapping at: 'xs') = 't1 allButFirst: 2'. self mappingOf: '0>>foo: {x. y. z|xs}'. self assert: mapping size = 4. self assert: (mapping at: 'x') = 't1 at: 1'. self assert: (mapping at: 'y') = 't1 at: 2'. self assert: (mapping at: 'z') = 't1 at: 3'. self assert: (mapping at: 'xs') = 't1 allButFirst: 3'. self mappingOf: '0>>foo: {x|nil}'. self assert: mapping size = 1. self assert: (mapping at: 'x') = 't1 at: 1'.! ! !PMVisitorTest methodsFor: 'testing-arguments' stamp: 'lr 12/8/2003 21:51'! testListArgument self mappingOf: '0>>foo: {}'. self assert: mapping size = 0. self mappingOf: '0>>foo: {x}'. self assert: mapping size = 1. self assert: (mapping at: 'x') = 't1 at: 1'. self mappingOf: '0>>foo: {x.y}'. self assert: mapping size = 2. self assert: (mapping at: 'x') = 't1 at: 1'. self assert: (mapping at: 'y') = 't1 at: 2'. self mappingOf: '0>>foo: {x.y.z}'. self assert: mapping size = 3. self assert: (mapping at: 'x') = 't1 at: 1'. self assert: (mapping at: 'y') = 't1 at: 2'. self assert: (mapping at: 'z') = 't1 at: 3'. self mappingOf: '0>>foo: {true. y. false}'. self assert: mapping size = 1. self assert: (mapping at: 'y') = 't1 at: 2'. ! ! !PMVisitorTest methodsFor: 'testing-printing' stamp: 'lr 12/4/2003 10:10'! testConditionPrinting self assertFunction: 'a>>foo if: [ self foo ]'. self assertFunction: 'a>>foo if: [ self foo ]'.! ! !PMVisitorTest methodsFor: 'testing-arguments' stamp: 'lr 12/8/2003 21:58'! testNestedListArgument self mappingOf: '0>>foo: {x|{}}'. self assert: mapping size = 1. self assert: (mapping at: 'x') = 't1 at: 1'. self mappingOf: '0>>foo: {x|{y}}'. self assert: mapping size = 2. self assert: (mapping at: 'x') = 't1 at: 1'. self assert: (mapping at: 'y') = '(t1 allButFirst: 1) at: 1'. self mappingOf: '0>>foo: {x|{y|ys}}'. self assert: mapping size = 3. self assert: (mapping at: 'x') = 't1 at: 1'. self assert: (mapping at: 'y') = '(t1 allButFirst: 1) at: 1'. self assert: (mapping at: 'ys') = '(t1 allButFirst: 1) allButFirst: 1'. ! ! !PMVisitorTest methodsFor: 'testing-arguments' stamp: 'lr 12/8/2003 22:00'! testReceiverArgument self mappingOf: 'a>>foo'. self assert: mapping size = 1. self assert: (mapping at: 'a') = 'self'. self mappingOf: '[ :a | a isFoo ]>>foo'. self assert: mapping size = 1. self assert: (mapping at: 'a') = 'self'. self mappingOf: 'anAssociation>>foo'. self assert: mapping size = 1. self assert: (mapping at: 'anAssociation') = 'self'. self mappingOf: '{x|xs}>>foo'. self assert: mapping size = 2. self assert: (mapping at: 'x') = 'self at: 1'. self assert: (mapping at: 'xs') = 'self allButFirst: 1'. ! ! !PMVisitorTest methodsFor: 'utility' stamp: 'lr 12/2/2003 12:40'! assertSignature: aString self assert: (self parse: aString) asString = aString! ! !PMVisitorTest methodsFor: 'testing-arguments' stamp: 'lr 12/8/2003 22:04'! 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: 'utility' stamp: 'lr 12/4/2003 10:11'! assertFunction: aString | output | output _ String streamContents: [ :stream | PMFunctionPrinter print: (self parse: aString) on: stream ]. self assert: aString = output.! ! !PMVisitorTest methodsFor: 'testing-printing' stamp: 'lr 12/8/2003 22:05'! 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: 123'. self assertSignature: 'a>>foo: 123.456'. self assertSignature: 'a>>foo: $a'. self assertSignature: 'a>>foo: ''abc'''. self assertSignature: 'a>>foo: #abc:abc:'. self assertSignature: 'a>>foo'. self assertSignature: '0>>foo'. self assertSignature: '{}>>foo'. self assertSignature: 'a>>foo: #''a b c'''. self assertSignature: 'a>>foo: #abc'. self assertSignature: 'a>>foo: #+'. self assertSignature: 'a>>foo: #abc:'. self assertSignature: 'a>>foo: #abc:abc:'. self assertSignature: 'a>>foo: [ :b | b ]'. self assertSignature: 'a>>foo: [ :b | b < 0 ]'. self assertSignature: 'a>>foo: [ :b | b asInteger < 0 ]'.! ! !PMVisitorTest methodsFor: 'testing-arguments' stamp: 'lr 12/8/2003 22:07'! testListInvalid self should: [ self mappingOf: 'a>>foo: a' ] raise: Error. self should: [ self mappingOf: 'a>>foo: {a}' ] raise: Error. self should: [ self mappingOf: 'a>>foo: {b.b}' ] raise: Error. self should: [ self mappingOf: 'a>>foo: {b.c|b}' ] raise: Error. self should: [ self mappingOf: 'a>>foo: [ :a | a isZork ]' ] raise: Error.! ! !PMVisitorTest methodsFor: 'testing-printing' stamp: 'lr 12/4/2003 21:37'! testBodyPrinting self assertFunction: 'a>>foo ^self foo'. self assertFunction: 'a>>foo ^self foo'.! ! PMFunctionalTest subclass: #PMParserTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Tests'! !PMParserTest methodsFor: 'testing-pattern' stamp: 'lr 12/8/2003 21:12'! 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 receiverClass == True. self assert: function arguments first pattern object = true. self assert: function arguments first pattern isLiteral. function _ self parse: 'a>>foo: false'. self assert: function arguments first pattern class == PMObjectPattern. self assert: function arguments first pattern parent == function arguments first. self assert: function arguments first pattern receiverClass == False. self assert: function arguments first pattern object = false. self assert: function arguments first pattern isLiteral. function _ self parse: 'a>>foo: nil'. self assert: function arguments first pattern class == PMObjectPattern. self assert: function arguments first pattern parent == function arguments first. self assert: function arguments first pattern receiverClass == UndefinedObject. self assert: function arguments first pattern object = nil. self assert: function arguments first pattern isLiteral. function _ self parse: 'a>>foo: 123'. self assert: function arguments first pattern class == PMObjectPattern. self assert: function arguments first pattern parent == function arguments first. self assert: function arguments first pattern receiverClass == SmallInteger. self assert: function arguments first pattern object = 123. self assert: function arguments first pattern isLiteral. function _ self parse: 'a>>foo: 1.23'. self assert: function arguments first pattern class == PMObjectPattern. self assert: function arguments first pattern parent == function arguments first. self assert: function arguments first pattern receiverClass == Float. self assert: function arguments first pattern object = 1.23. self assert: function arguments first pattern isLiteral. function _ self parse: 'a>>foo: #abc'. self assert: function arguments first pattern class == PMObjectPattern. self assert: function arguments first pattern parent == function arguments first. self assert: function arguments first pattern receiverClass == Symbol. self assert: function arguments first pattern object = #abc. self assert: function arguments first pattern isLiteral. function _ self parse: 'a>>foo: #a:b:c:'. self assert: function arguments first pattern class == PMObjectPattern. self assert: function arguments first pattern parent == function arguments first. self assert: function arguments first pattern receiverClass == Symbol. self assert: function arguments first pattern object = #a:b:c:. self assert: function arguments first pattern isLiteral. function _ self parse: 'a>>foo: #''abc'''. self assert: function arguments first pattern class == PMObjectPattern. self assert: function arguments first pattern parent == function arguments first. self assert: function arguments first pattern receiverClass == Symbol. self assert: function arguments first pattern object = #'abc'. self assert: function arguments first pattern isLiteral. function _ self parse: 'a>>foo: #++'. self assert: function arguments first pattern class == PMObjectPattern. self assert: function arguments first pattern parent == function arguments first. self assert: function arguments first pattern receiverClass == Symbol. self assert: function arguments first pattern object = #++. self assert: function arguments first pattern isLiteral.! ! !PMParserTest methodsFor: 'testing' stamp: 'lr 12/3/2003 21:22'! testBodyError self should: [ self parse: 'a>>b ^' ] raise: SmaCCParserError. self should: [ self parse: 'a>>b [' ] raise: SmaCCParserError. self should: [ self parse: 'a>>b ]' ] raise: SmaCCParserError. self should: [ self parse: 'a>>b * 1' ] raise: SmaCCParserError. ! ! !PMParserTest methodsFor: 'testing' stamp: 'lr 12/8/2003 20:32'! testBlockPatternError self should: [ self parse: 'anInteger>>foo: [' ] raise: SmaCCParserError. self should: [ self parse: 'anInteger>>foo: []' ] raise: SmaCCParserError. self should: [ self parse: 'anInteger>>foo: [:|' ] raise: SmaCCParserError. self should: [ self parse: 'anInteger>>foo: [:a|' ] raise: SmaCCParserError. self should: [ self parse: 'anInteger>>foo: [:a|a+' ] raise: SmaCCParserError.! ! !PMParserTest methodsFor: 'testing-selector' stamp: 'lr 12/8/2003 21:19'! testSelector function _ self parse: 'a>>foo'. self assert: function arguments first class == PMSelector. self assert: function arguments first parent == function. self assert: function arguments first selector = #foo. function _ self parse: 'a>>foo: b'. self assert: function arguments first class == PMMatchedSelector. self assert: function arguments first parent == function. self assert: function arguments first selector = #foo:. self assert: function arguments first pattern class == PMVariablePattern. self assert: function arguments first pattern parent == function arguments first. self assert: function arguments first pattern name = 'b'.! ! !PMParserTest methodsFor: 'testing-pattern' stamp: 'lr 12/8/2003 21:16'! testVariable function _ self parse: 'a>>foo: b'. self assert: function arguments first class == PMMatchedSelector. self assert: function arguments first parent == function. self assert: function arguments first selector = #foo:. self assert: function arguments first pattern class == PMVariablePattern. self assert: function arguments first pattern parent == function arguments first. self assert: function arguments first pattern name = 'b'.! ! !PMParserTest methodsFor: 'testing-code' stamp: 'lr 12/8/2003 21:09'! 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 = 'a'. 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 = 'a'. 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 = 'a'. self assert: function condition parent == function.! ! !PMParserTest methodsFor: 'testing-pattern' stamp: 'lr 12/9/2003 20:00'! testBlock function _ self parse: 'a>>foo: [ :b | b ]'. self assert: function arguments first pattern class == PMBlockPattern. self assert: function arguments first pattern parent == function arguments first. self assert: function arguments first pattern name = 'b'. self assert: function arguments first pattern expression class == PMExpression. self assert: function arguments first pattern expression parent == function arguments first pattern. self assert: function arguments first pattern expression source = ' b '. self assert: function arguments first pattern expression node class == RBVariableNode. self assert: function arguments first pattern expression node name = 'b'.! ! !PMParserTest methodsFor: 'testing' stamp: 'lr 12/8/2003 21:08'! testWhitespace function _ self parse: 'a>>foo: b if: [a]b'. self assert: function receiver class == PMVariablePattern. self assert: function receiver name = 'a'. self assert: function selector = #foo:. self assert: function arguments first class == PMMatchedSelector. self assert: function arguments first selector = #foo:. self assert: function arguments first pattern class == PMVariablePattern. self assert: function arguments first pattern name = 'b'. self assert: function condition class == PMExpression. self assert: function condition source = 'a'. self assert: function body class == PMExpression. self assert: function body source = 'b'. function _ self parse: 'a >> foo: b if: [ a ] b'. self assert: function receiver class == PMVariablePattern. self assert: function receiver name = 'a'. self assert: function selector = #foo:. self assert: function arguments first class == PMMatchedSelector. self assert: function arguments first selector = #foo:. self assert: function arguments first pattern class == PMVariablePattern. self assert: function arguments first pattern name = 'b'. self assert: function condition class == PMExpression. self assert: function condition source = ' a '. self assert: function body class == PMExpression. self assert: function body source = ' b'. function _ self parse: 'a>> foo: b if: [ a ] b '. self assert: function receiver class == PMVariablePattern. self assert: function receiver name = 'a'. self assert: function selector = #foo:. self assert: function arguments first class == PMMatchedSelector. self assert: function arguments first selector = #foo:. self assert: function arguments first pattern class == PMVariablePattern. self assert: function arguments first pattern name = 'b'. self assert: function condition class == PMExpression. self assert: function condition source = ' a '. self assert: function body class == PMExpression. self assert: function body source = ' b '. ! ! !PMParserTest methodsFor: 'testing-pattern' stamp: 'lr 12/8/2003 21:12'! 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 receiverClass == String. self assert: function arguments first pattern object = 'abc'. self deny: function arguments first pattern isLiteral.! ! !PMParserTest methodsFor: 'testing' stamp: 'lr 12/3/2003 21:31'! testConditionError self should: [ self parse: 'a>>b if: [' ] raise: SmaCCParserError. self should: [ self parse: 'a>>b if: [[' ] raise: SmaCCParserError. self should: [ self parse: 'a>>b if: []]' ] raise: SmaCCParserError. self should: [ self parse: 'a>>b if: [1+' ] raise: SmaCCParserError.! ! !PMParserTest methodsFor: 'testing-selector' stamp: 'lr 12/2/2003 12:39'! testBinarySelector function _ self parse: 'a>>+ b'. self assert: function selector = #+. self assert: function arguments size = 1. function _ self parse: 'a>>== b'. self assert: function selector = #==. self assert: function arguments size = 1. function _ self parse: 'a>>// b'. self assert: function selector = #//. self assert: function arguments size = 1. ! ! !PMParserTest methodsFor: 'testing-pattern' stamp: 'lr 12/8/2003 21:15'! testOpenList function _ self parse: 'a>>foo: {x|xs}'. self assert: function arguments first pattern class == PMOpenListPattern. self assert: function arguments first pattern parent == function arguments first. self assert: function arguments first pattern size = 1. self deny: function arguments first pattern isEmpty. self assert: function arguments first pattern items first class == PMVariablePattern. self assert: function arguments first pattern items first parent == function arguments first pattern. self assert: function arguments first pattern items first name = 'x'. self assert: function arguments first pattern tail class == PMVariablePattern. self assert: function arguments first pattern tail parent == function arguments first pattern. self assert: function arguments first pattern tail name = 'xs'. function _ self parse: 'a>>foo: {x|{y}}'. self assert: function arguments first pattern class == PMOpenListPattern. self assert: function arguments first pattern parent == function arguments first. self assert: function arguments first pattern size = 1. self deny: function arguments first pattern isEmpty. self assert: function arguments first pattern items first class == PMVariablePattern. self assert: function arguments first pattern items first parent == function arguments first pattern. self assert: function arguments first pattern items first name = 'x'. self assert: function arguments first pattern tail class == PMListPattern. self assert: function arguments first pattern tail parent == function arguments first pattern. self assert: function arguments first pattern tail items size = 1. self assert: function arguments first pattern tail items first class == PMVariablePattern. self assert: function arguments first pattern tail items first parent == function arguments first pattern tail. self assert: function arguments first pattern tail items first name = 'y'.! ! !PMParserTest methodsFor: 'testing-code' stamp: 'lr 12/8/2003 21:09'! testBoth function _ self parse: 'a>>foo if: [ a ] b'. self assert: function condition class == PMExpression. self assert: function condition source = ' a '. self assert: function condition parent == function. self assert: function body class == PMExpression. self assert: function body source = ' b'. self assert: function body parent == function. function _ self parse: 'a>>+ b if: [ a ] b'. self assert: function condition class == PMExpression. self assert: function condition source = ' a '. self assert: function condition parent == function. self assert: function body class == PMExpression. self assert: function body source = ' b'. self assert: function body parent == function. function _ self parse: 'a>>foo: b if: [ a ] b'. self assert: function condition class == PMExpression. self assert: function condition source = ' a '. self assert: function condition parent == function. self assert: function body class == PMExpression. self assert: function body source = ' b'. self assert: function body parent == function. ! ! !PMParserTest methodsFor: 'testing-selector' stamp: 'lr 12/2/2003 12:40'! testUnarySelector function _ self parse: 'a>>foo'. self assert: function selector = #foo. self assert: function arguments size = 1.! ! !PMParserTest methodsFor: 'testing' stamp: 'lr 12/8/2003 20:33'! testListPatternError self should: [ self parse: 'anInteger>>foo: {' ] raise: SmaCCParserError. self should: [ self parse: 'anInteger>>foo: {a' ] raise: SmaCCParserError. self should: [ self parse: 'anInteger>>foo: {a|' ] raise: SmaCCParserError. self should: [ self parse: 'anInteger>>foo: {a|b' ] raise: SmaCCParserError. self should: [ self parse: 'anInteger>>foo: {a|b|' ] raise: SmaCCParserError.! ! !PMParserTest methodsFor: 'testing-pattern' stamp: 'lr 12/8/2003 21:10'! testClass function _ self parse: 'a>>foo: aPoint'. self assert: function arguments first pattern class == PMClassPattern. self assert: function arguments first pattern parent == function arguments first. self assert: function arguments first pattern name = 'aPoint'. self assert: function arguments first pattern target == Point. function _ self parse: 'a>>foo: anInteger'. self assert: function arguments first pattern class == PMClassPattern. self assert: function arguments first pattern parent == function arguments first. self assert: function arguments first pattern name = 'anInteger'. self assert: function arguments first pattern target == Integer.! ! !PMParserTest methodsFor: 'testing' stamp: 'lr 12/8/2003 20:31'! testPatternBlockError self should: [ self parse: 'anInteger>>foo: [' ] raise: SmaCCParserError. self should: [ self parse: 'anInteger>>foo: []' ] raise: SmaCCParserError. self should: [ self parse: 'anInteger>>foo: [:|' ] raise: SmaCCParserError. self should: [ self parse: 'anInteger>>foo: [:a|' ] raise: SmaCCParserError. self should: [ self parse: 'anInteger>>foo: [:a|a+' ] raise: SmaCCParserError.! ! !PMParserTest methodsFor: 'testing-pattern' stamp: 'lr 12/8/2003 21:16'! testReceiver function _ self parse: 'a>>foo'. self assert: function receiver class == PMVariablePattern. self assert: function receiver parent == function. self assert: function receiver name = 'a'. function _ self parse: '0>>foo'. self assert: function receiver class == PMObjectPattern. self assert: function receiver parent == function. self assert: function receiver object = 0. function _ self parse: '{}>>foo'. self assert: function receiver class == PMListPattern. self assert: function receiver parent == function. self assert: function receiver isEmpty.! ! !PMParserTest methodsFor: 'testing-selector' stamp: 'lr 12/2/2003 12:39'! testKeywordSelector function _ self parse: 'a>>foo: b'. self assert: function selector = #foo:. self assert: function arguments size = 1. function _ self parse: 'a>>foo: b bar: c'. self assert: function selector = #foo:bar:. self assert: function arguments size = 2. function _ self parse: 'a>>foo: b bar: c zork: d'. self assert: function selector = #foo:bar:zork:. self assert: function arguments size = 3. ! ! !PMParserTest methodsFor: 'testing' stamp: 'lr 12/4/2003 10:33'! testSignatureError self should: [ self parse: '' ] raise: SmaCCParserError. self should: [ self parse: '>>' ] raise: SmaCCParserError. self should: [ self parse: 'anInteger' ] raise: SmaCCParserError. self should: [ self parse: 'anInteger>>' ] raise: SmaCCParserError. self should: [ self parse: 'anInteger>>+' ] raise: SmaCCParserError. self should: [ self parse: 'anInteger>>foo:' ] raise: SmaCCParserError. self should: [ self parse: 'anInteger>>foo: [' ] raise: SmaCCParserError. self should: [ self parse: 'anInteger>>foo: []' ] raise: SmaCCParserError. self should: [ self parse: 'anInteger>>foo: [:|' ] raise: SmaCCParserError. self should: [ self parse: 'anInteger>>foo: [:a|' ] raise: SmaCCParserError. self should: [ self parse: 'anInteger>>foo: [:a|a+' ] raise: SmaCCParserError. ! ! !PMParserTest methodsFor: 'testing-code' stamp: 'lr 12/8/2003 21:08'! 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 = 'a'. 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 = 'a'. 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 = 'a'. self assert: function body parent == function.! ! !PMParserTest methodsFor: 'testing-pattern' stamp: 'lr 12/8/2003 21:10'! testList function _ self parse: 'a>>foo: {}'. self assert: function arguments first pattern class == PMListPattern. self assert: function arguments first pattern parent == function arguments first. self assert: function arguments first pattern size = 0. self assert: function arguments first pattern isEmpty. function _ self parse: 'a>>foo: {x}'. self assert: function arguments first pattern class == PMListPattern. self assert: function arguments first pattern parent == function arguments first. self assert: function arguments first pattern size = 1. self deny: function arguments first pattern isEmpty. self assert: function arguments first pattern items first class == PMVariablePattern. self assert: function arguments first pattern items first parent == function arguments first pattern. self assert: function arguments first pattern items first name = 'x'. function _ self parse: 'a>>foo: {x.y}'. self assert: function arguments first pattern class == PMListPattern. self assert: function arguments first pattern parent == function arguments first. self assert: function arguments first pattern size = 2. self deny: function arguments first pattern isEmpty. self assert: function arguments first pattern items first class == PMVariablePattern. self assert: function arguments first pattern items first parent == function arguments first pattern. self assert: function arguments first pattern items first name = 'x'. self assert: function arguments first pattern items second class == PMVariablePattern. self assert: function arguments first pattern items second parent == function arguments first pattern. self assert: function arguments first pattern items second name = 'y'. ! ! PMFunctionalTest subclass: #PMCategoryTest instanceVariableNames: 'category mock ' classVariableNames: '' poolDictionaries: '' category: 'Pattern-Tests'! !PMCategoryTest methodsFor: 'testing-build' stamp: 'lr 12/8/2003 23:15'! testQuicksortKeyword category add: (self parse: 'aPMMock>>testQuicksort: {} ^Array new'). category add: (self parse: 'aPMMock>>testQuicksort: {x|xs} ^(self testQuicksort: (xs select: [ :each | each < x ])) , (Array with: x) , (self testQuicksort: (xs reject: [ :each | each < x ]))'). self assert: #testQuicksort: in: mock. 10 timesRepeat: [ self assert: (mock testQuicksort: (1 to: 10) asArray shuffled) = (1 to: 10) asArray ]. ! ! !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-build' stamp: 'lr 12/8/2003 22:53'! testQuicksortUnary category add: (self parse: '{}>>testQuicksort ^Array new'). category add: (self parse: '{x|xs}>>testQuicksort ^(xs select: [ :each | each < x ]) testQuicksort , (Array with: x) , (xs reject: [ :each | each < x ]) testQuicksort'). self assert: #testQuicksort in: SequenceableCollection new. 10 timesRepeat: [ self assert: ((1 to: 10) asArray shuffled testQuicksort) = ((1 to: 10) asArray) ]. ! ! !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'! testRemoveAll category removeAll. self assert: category functions size = 0. self deny: #testFib: in: mock.! ! !PMCategoryTest methodsFor: 'running' stamp: 'lr 12/8/2003 23:01'! setUp mock _ PMMock new. category _ PMCategory name: 'Mock'. 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: 'utility' stamp: 'lr 12/7/2003 20:49'! assertSelectors: aBlock Smalltalk allClasses do: [ :class | class selectors do: [ :each | aBlock value: class value: each ] ]! ! !PMCategoryTest methodsFor: 'utility' stamp: 'lr 12/7/2003 20:53'! deny: aSelector in: anObject self deny: (anObject class includesSelector: aSelector)! ! !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. ! ! !PMCategoryTest methodsFor: 'running' stamp: 'lr 12/8/2003 22:51'! tearDown category removeAll! ! !PMCategoryTest methodsFor: 'utility' stamp: 'lr 12/7/2003 20:49'! assertCategories: aBlock Smalltalk allClasses do: [ :class | class organization categories do: [ :each | aBlock value: class value: each ] ]! ! !PMCategoryTest methodsFor: 'testing-build' stamp: 'lr 12/8/2003 23:03'! 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.! ! !PMCategoryTest methodsFor: 'utility' stamp: 'lr 12/7/2003 20:53'! assert: aSelector in: anObject self assert: (anObject class includesSelector: aSelector)! ! !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-utility' stamp: 'lr 12/7/2003 21:39'! 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 ].! ! !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.! ! !PMFunctionalTest methodsFor: 'utility' stamp: 'lr 12/2/2003 19:02'! parse: aString ^PMParser parse: aString! !