2006-01-11 Stephen Compall * compiler/ParseTreeSearcher.st (ParseTreeRewriter): Add visitField:ofNode:, visitNode:onMatch:, visitListField:ofNode:, similar methods, and support for them. Use the field visiting methods where possible in lookForMoreMatchesInContext: and accept*:. Make acceptCascadeNode: more readable. --- orig/compiler/ParseTreeSearcher.st +++ mod/compiler/ParseTreeSearcher.st @@ -296,10 +296,7 @@ !RBSmallDictionary class methodsFor: 'instance creation'! new - ^self new: 2! - -new: anInteger - ^(self basicNew: anInteger) initialize: anInteger! ! + ^self new: 2! ! RBProgramNodeVisitor subclass: #ParseTreeSearcher @@ -746,79 +743,162 @@ answer := true! lookForMoreMatchesInContext: oldContext - oldContext keysAndValuesDo: - [:key :value | - (key isString not and: [key recurseInto]) - ifTrue: - [oldContext at: key put: (value collect: [:each | self visitNode: each])]]! ! + oldContext keysAndValuesDo: [:key :value | + (key isString not and: [key recurseInto]) ifTrue: [ + self visitNodeList: value visitor: #visitNode:onMatch: + onMatch: [:newValue | + oldContext at: key put: newValue]]]! ! !ParseTreeRewriter methodsFor: 'visiting'! -visitArguments: aNodeCollection - ^aNodeCollection collect: [:each | self visitArgument: each]! ! +visitNode: aNode + ^self visitNode: aNode onMatch: [:newNode |]! + +visitArgument: aNode + ^self visitArgument: aNode onMatch: [:newNode |]! + +visitNode: aNode onMatch: aBlock + "Visit aNode, sending visitNode:'s answer to aBlock if + performSearches:on: finds a match." + | newNode | + newNode := self performSearches: searches on: aNode. + ^newNode isNil ifTrue: [aNode acceptVisitor: self. aNode] + ifFalse: [aBlock value: newNode. newNode]! + +visitArgument: aNode onMatch: aBlock + "Visit aNode, sending visitNode:'s answer to aBlock if + performSearches:on: finds a match." + | newNode | + newNode := self performSearches: argumentSearches on: aNode. + ^newNode isNil ifTrue: [aNode acceptVisitor: self. aNode] + ifFalse: [aBlock value: newNode. newNode]! + +visitNodeList: aNodeList visitor: vSelector onMatch: aBlock + "Answer aNodeList but with each element replaced by the result of + sending vSelector to me with said element (and a block of my + own). If any matches occur, I'll call aBlock afterwards with the + replacement of aNodeList before answering it." + | replacementList rlHasMatch | + rlHasMatch := false. + replacementList := aNodeList collect: [:eltNode | + self perform: vSelector with: eltNode + with: [:newElt | rlHasMatch := true]]. + ^rlHasMatch + ifTrue: [aBlock value: replacementList. replacementList] + ifFalse: [aNodeList]! + +!ParseTreeRewriter methodsFor: 'visiting node fields'! + +visitField: fieldName ofNode: aNode + "Visit aNode's fieldName node, setting it to the replacement node + if it changes." + | origNode | + origNode := aNode perform: fieldName. + self visitNode: origNode onMatch: [:newNode | + origNode == newNode ifFalse: [ + self setField: fieldName ofNode: aNode to: newNode]]! + +visitCollectionField: fieldName ofNode: aNode visitor: vSelector + "Implement behavior of visitListField:ofNode: and + visitArgumentsField:ofNode:." + | origList | + origList := aNode perform: fieldName. + self visitNodeList: origList visitor: vSelector onMatch: + [:newList | + origList with: newList do: [:origElt :newElt | + origElt == newElt ifFalse: [ + self setField: fieldName ofNode: aNode to: newList. + ^self]]]! + +visitListField: fieldName ofNode: aNode + "Visit aNode's fieldName, a collection of nodes, setting it to the + replacement node collection if it changes." + self visitCollectionField: fieldName ofNode: aNode + visitor: #visitNode:onMatch:! + +visitArgumentsField: fieldName ofNode: aNode + "Visit aNode's fieldName, a collection of argument nodes, setting + it to the replacement node collection if it changes." + self visitCollectionField: fieldName ofNode: aNode + visitor: #visitArgument:onMatch:! + +setField: fieldName ofNode: aNode to: newValue + "Transform fieldName, a getter selector, to its complementary + setter selector, sending it with newValue to aNode." + aNode perform: (fieldName copyWith: $:) asSymbol + with: newValue! ! !ParseTreeRewriter methodsFor: 'visitor-double dispatching'! acceptAssignmentNode: anAssignmentNode - anAssignmentNode variable: (self visitNode: anAssignmentNode variable). - anAssignmentNode value: (self visitNode: anAssignmentNode value)! + self visitField: #variable ofNode: anAssignmentNode; + visitField: #value ofNode: anAssignmentNode! acceptArrayConstructorNode: anArrayNode - anArrayNode body: (self visitNode: anArrayNode body)! + self visitField: #body ofNode: anArrayNode! acceptBlockNode: aBlockNode - aBlockNode arguments: (self visitArguments: aBlockNode arguments). - aBlockNode body: (self visitNode: aBlockNode body)! + self visitArgumentsField: #arguments ofNode: aBlockNode; + visitField: #body ofNode: aBlockNode! + +searchCascadeNodeMessage: aMessageNode messagesTo: newMessages + "Helper for acceptCascadeNode: -- descend to aMessageNode, but no + further. Add the resulting message or cascade of messages from + the tree rule's foundMatchFor: to newMessages and answer said + result if a match is found. Add aMessageNode to newMessages and + answer nil otherwise." + | answer newNode | + answer := self performSearches: searches on: aMessageNode. + newNode := answer ifNil: [aMessageNode]. + newNode isCascade + ifTrue: [newMessages addAll: newNode messages] + ifFalse: [newMessages add: + (newNode isMessage ifTrue: [newNode] + ifFalse: [Warning signal: 'Cannot replace message node inside of cascaded node with non-message node'. + aMessageNode])]. + ^answer! acceptCascadeNode: aCascadeNode | newMessages notFound | newMessages := OrderedCollection new: aCascadeNode messages size. notFound := OrderedCollection new: aCascadeNode messages size. - aCascadeNode messages do: - [:each | - | newNode | - newNode := self performSearches: searches on: each. - newNode isNil - ifTrue: - [newNode := each. - notFound add: newNode]. - newNode isMessage - ifTrue: [newMessages add: newNode] - ifFalse: - [newNode isCascade - ifTrue: [newMessages addAll: newNode messages] - ifFalse: - [Transcript - show: 'Cannot replace message node inside of cascaded node with non-message node.'; - cr. - newMessages add: each]]]. + aCascadeNode messages do: [:each | + (self searchCascadeNodeMessage: each + messagesTo: newMessages) + isNil ifTrue: [notFound add: each]]. + + "Rewrite the receiver once and distribute it among the messages if + no replacements were made." notFound size == aCascadeNode messages size ifTrue: [| receiver | - receiver := self visitNode: aCascadeNode messages first receiver. + self visitField: #receiver + ofNode: aCascadeNode messages first. + receiver := aCascadeNode messages first receiver. newMessages do: [:each | each receiver: receiver]]. + + "Only rewrite arguments of messages that weren't replaced above." notFound - do: [:each | each arguments: (each arguments collect: [:arg | self visitNode: arg])]. + do: [:each | self visitListField: #arguments ofNode: each]. aCascadeNode messages: newMessages! acceptMessageNode: aMessageNode - aMessageNode receiver: (self visitNode: aMessageNode receiver). - aMessageNode - arguments: (aMessageNode arguments collect: [:each | self visitNode: each])! + self visitField: #receiver ofNode: aMessageNode; + visitListField: #arguments ofNode: aMessageNode! acceptMethodNode: aMethodNode - aMethodNode arguments: (self visitArguments: aMethodNode arguments). - aMethodNode body: (self visitNode: aMethodNode body)! + self visitArgumentsField: #arguments ofNode: aMethodNode; + visitField: #body ofNode: aMethodNode! acceptOptimizedNode: anOptimizedNode - anOptimizedNode body: (self visitNode: anOptimizedNode body)! + self visitField: #body ofNode: anOptimizedNode! acceptReturnNode: aReturnNode - aReturnNode value: (self visitNode: aReturnNode value)! + self visitField: #value ofNode: aReturnNode! acceptSequenceNode: aSequenceNode - aSequenceNode temporaries: (self visitArguments: aSequenceNode temporaries). - aSequenceNode statements: (aSequenceNode statements collect: [:each | self visitNode: each])! ! + self visitArgumentsField: #temporaries ofNode: aSequenceNode; + visitListField: #statements ofNode: aSequenceNode! ! ParseTreeRewriter class instanceVariableNames: ''!