On Wed, 2007-01-10 at 22:53 -0600, Stephen Compall wrote: > I've named the two issues non-messages-are-found and rsic-doesnt-copy, > respectively.
Attached are alternate refactorings of ParseTreeRewriter. ptrrefactor-pre-fixes.diff passes http://scompall.nocandysw.com/gst/ptrtests.st . It doesn't include fixes for the two issues. ptrrefactor-post-fixes.diff passes http://scompall.nocandysw.com/gst/ptrtests-post-nmaf+rdc.st . It does include fixes. Both have changelog entries. -- Stephen Compall http://scompall.nocandysw.com/blog
2006-01-11 Stephen Compall <[EMAIL PROTECTED]>
* 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: ''!
2006-01-11 Stephen Compall <[EMAIL PROTECTED]>
* 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.
Copy context node pattern variables before rewriting them, in case
they are mutated and their containing replacement is later
rejected. Mark each message in a cascade node with an invalid
replacement for visiting of its arguments.
--- 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,165 @@
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: (oldContext at: key put:
+ (value collect: [:v | v copy]))
+ 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'.
+ answer := nil.
+ 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: ''!
signature.asc
Description: This is a digitally signed message part
_______________________________________________ help-smalltalk mailing list [email protected] http://lists.gnu.org/mailman/listinfo/help-smalltalk
