last tests patch for a while -- ParseTreeRewriter

This incorporates Stephen's ParseTreeRewriter tests, and fixes the bugs
exposed by the tests.

Paolo

2007-05-22  Stephen Compall  <[hidden email]>
            Paolo Bonzini  <[hidden email]>

        * compiler/RewriteTests.st: New.
        * compiler/ParseTreeSearcher.st: Fix two bugs.

--- orig/compiler/ParseTreeSearcher.st
+++ mod/compiler/ParseTreeSearcher.st
@@ -762,7 +762,7 @@ lookForMoreMatchesInContext: oldContext
  (key isString not and: [key recurseInto]) ifTrue: [
     "Of course, the following statement does nothing without the `deepCopy'
      which fixes the bug."
-    newValue := oldContext at: key put: value "deepCopy <<<".
+    newValue := oldContext at: key put: value deepCopy "<<<".
     self visitNodes: newValue
          onMatch: [:newValue |
      oldContext at: key put: newValue]]]! !
@@ -845,7 +845,7 @@ searchCascadeNodeMessage: aMessageNode m
  ifFalse: [newMessages add:
       (newNode isMessage ifTrue: [newNode]
  ifFalse: [Warning signal: 'Cannot replace message node inside of cascaded node with non-message node'.
-           "answer := nil. <<<"
+           answer := nil. "<<<"
    aMessageNode])].
     ^answer!
 


--- orig/packages.xml.in
+++ mod/packages.xml.in
@@ -379,6 +379,9 @@
 
 <package>
   <name>Parser</name>
+  <sunit>STInST.Tests.TestStandardRewrites</sunit>
+  <prereq>SUnit</prereq>
+
   <namespace>STInST</namespace>
   <filein>RBToken.st</filein>
   <filein>RBParseNodes.st</filein>
@@ -393,6 +396,8 @@
   <filein>STLoaderObjs.st</filein>
   <filein>STLoader.st</filein>
 
+  <filein>RewriteTests.st</filein>
+
   <directory>compiler</directory>
 
   <file>ParseTreeSearcher.st</file>
@@ -400,13 +405,14 @@
   <file>RBParseNodes.st</file>
   <file>RBParser.st</file>
   <file>RBToken.st</file>
-  <filein>OrderedSet.st</filein>
+  <file>OrderedSet.st</file>
   <file>STCompLit.st</file>
   <file>STCompiler.st</file>
   <file>STDecompiler.st</file>
   <file>STLoader.st</file>
   <file>STLoaderObjs.st</file>
   <file>STSymTable.st</file>
+  <file>RewriteTests.st</file>
 </package>
 
 <package>


--- orig/tests/testsuite.at
+++ mod/tests/testsuite.at
@@ -69,6 +69,7 @@ AT_DIFF_TEST([strcat.st])
 
 AT_BANNER([Basic packages.])
 AT_PACKAGE_TEST([SUnit])
+AT_PACKAGE_TEST([Parser])
 
 AT_BANNER([ANSI compliancy tests.])
 AT_ANSI_TEST([ArrayANSITest])



--- /dev/null
+++ mod/compiler/RewriteTests.st
@@ -0,0 +1,240 @@
+"======================================================================
+|
+|   ParseTreeRewriter tests
+|
+|
+ ======================================================================"
+
+
+"======================================================================
+|
+| Copyright (C) 2007 Free Software Foundation, Inc.
+| Written by Stephen Compall.
+|
+| This file is part of the GNU Smalltalk class library.
+|
+| The GNU Smalltalk class library is free software; you can redistribute it
+| and/or modify it under the terms of the GNU Lesser General Public License
+| as published by the Free Software Foundation; either version 2.1, or (at
+| your option) any later version.
+|
+| The GNU Smalltalk class library is distributed in the hope that it will be
+| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of
+| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser
+| General Public License for more details.
+|
+| You should have received a copy of the GNU Lesser General Public License
+| along with the GNU Smalltalk class library; see the file COPYING.LIB.
+| If not, write to the Free Software Foundation, 59 Temple Place - Suite
+| 330, Boston, MA 02110-1301, USA.  
+|
+ ======================================================================"
+
+STInST addSubspace: #Tests!
+Namespace current: STInST.Tests!
+
+TestCase subclass: #TestStandardRewrites
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Refactory-Tests'
+!
+
+TestStandardRewrites comment:
+'I test the ParseTreeRewriter with string rewrites provided directly
+by PTR''s methods.
+
+This is a series of unit tests written with SUnit to check the
+functionality of STInST.ParseTreeRewriter and its
+helper classes.  It was written based on the original functionality,
+so that one could perform a radical rewrite and ensure that its
+behavior stayed the same, at least as much as I care it to stay so.'!
+
+
+!TestStandardRewrites methodsFor: 'testing'!
+
+testExpressions
+    "Basic testing of proper descent"
+    self rewrite: '(self foo: (one isNil ifTrue: [self uhOh. two]
+ ifFalse: [one]))
+       isNil ifTrue: [three isNil ifFalse: [three]
+  ifTrue: [four]]
+     ifFalse: [self foo: (one isNil ifTrue: [self uhOh. two] ifFalse: [one])]'
+ from: '``@receiver isNil ifTrue: [|`@otherVars| ``@.other]
+  ifFalse: [``@receiver]'
+ to: '``@receiver ifNil: [|`@otherVars| ``@.other]'
+ shouldBe: '(self foo: (one ifNil: [self uhOh. two]))
+ ifNil: [three isNil ifFalse: [three]
+    ifTrue: [four]]'.
+    "descent and simple replacement behavior with cascades"
+    self rewrite: '| temp |
+   temp := self one at: two put: three.
+   (self qqq at: temp put: dict)
+       at: four put: (five at: half put: quarter);
+       at: (six at: q put: r) put: 7;
+       w: (1 at: 2 put: 3).
+   ^42'
+ "``@receiver it was, until I found that a cascade corner
+  described below causes the w: send below to have the wrong
+  receiver.  After all, it just doesn't make sense to descend
+  to the receiver for some cascade messages but not others!"
+ from: '`@receiver at: ``@key put: `@value'
+ to: '`@receiver set: ``@key to: `@value'
+ shouldBe: '| temp |
+    temp := self one set: two to: three.
+    (self qqq at: temp put: dict)
+ set: four to: (five at: half put: quarter);
+ set: (six set: q to: r) to: 7;
+ w: (1 set: 2 to: 3).
+    ^42'.
+!
+
+testCascadeCornerCases
+    "Issue non-messages-are-found: If replacement isn't a cascade or
+     message, it drops.  Oddly, PTR didn't count this as a 'not
+     found'; it doesn't descend into arguments of the original node in
+     this case, and, as a result, it won't descend to the receiver.  This
+     behavior was changed, the original implementation needed this
+     shouldBe: content:
+
+ obj.
+        (stream display: z) display: (stream display: x);
+ display: y; nextPut: $q"
+    self rewrite: 'stream display: obj.
+   (stream display: z) display: (stream display: x);
+       display: y; nextPut: $q'
+ from: '``@receiver display: ``@object'
+ to: '``@object'
+ shouldBe: 'obj.
+    z display: x;
+ display: y; nextPut: $q'.
+
+    "Cascades within cascades are flattened."
+    self rewrite: 'stream nextPut: $r; display: (what display: qqq); tab'
+ from: '``@recv display: ``@obj'
+ to: '``@recv display: ``@obj; nl'
+ shouldBe: 'stream nextPut: $r;
+ display: (what display: qqq; nl);
+ nl; tab'.
+
+    "Issue rsic-doesnt-copy: lookForMoreMatchesInContext: doesn't copy
+     its values.  As a result, replacement in successful replacements
+     later rejected by acceptCascadeNode: (after
+     lookForMoreMatchesInContext: is already sent, after all) depends
+     on where in the subtree a match happened.  This is why selective
+     recursion into successful matches before giving outer contexts
+     the opportunity to reject them isn't so great.  It can be 'fixed'
+     by #copy-ing each value in the context before descending into it.
+     I would prefer removing that 'feature' altogether, and my own
+     'trampoline' rewriter does just this.
+
+     This replacement test depends on the non-message rejection oddity
+     described above, though fixing that won't entirely fix this
+     issue.  If that issue is not, this test will need this shouldBe:
+ qqq display: (qqq display: sss);
+     display: [[sss]]'"
+    self rewrite: 'qqq display: (qqq display: sss);
+       display: [qqq display: sss]'
+ from: '``@recv display: ``@obj'
+ to: '[``@obj]'
+ shouldBe: 'qqq display: [sss];
+ display: [[sss]]'.
+    [| rsicCopiesPRewriter sourceExp |
+     rsicCopiesPRewriter := self rewriterClass new
+   replace: '``@recv display: ``@obj' with: '[``@obj]';
+   replace: '`@recv value' with: '`@recv';
+   yourself.
+     sourceExp := RBParser parseExpression:
+ 'qqq display: (qqq display: sss value value);
+      display: [qqq display: sss value value]'.
+     self deny: (self rewriting: sourceExp
+ with: rsicCopiesPRewriter
+ yields:
+    'qqq display: (qqq display: sss value value);
+      display: [[sss value]]')
+  description:
+      'neither non-messages-are-found nor rsic-doesnt-copy fixed'.
+     self deny: (self rewriting: sourceExp
+      with: rsicCopiesPRewriter
+      yields:
+  'qqq display: [sss value];
+    display: [[sss]]')
+  description:
+      'non-messages-are-found fixed, but not rsic-doesnt-copy'.
+     self assert: (self rewriting: sourceExp
+      with: rsicCopiesPRewriter
+      yields:
+  'qqq display: [sss value];
+    display: [[sss value]]')
+  description:
+      'both non-messages-are-found and rsic-doesnt-copy fixed'.]
+ value.
+
+    "Unmatched messages in a cascade get their arguments rewritten,
+     but not the receiver, provided that some other message in the
+     cascade was rewritten.  This can lead to unreal trees if that
+     message had a recurseInto receiver."
+    self assert:
+ ((RBCascadeNode messages:
+      (RBParser parseExpression: '(1 b) b. (1 a) c') statements)
+     match: (self rewriterClass
+ replace: '``@recv a'
+ with: '``@recv b'
+ in: (RBParser parseExpression: '(1 a) a; c'))
+     inContext: RBSmallDictionary new)
+ description: 'Don''t rewrite cascade receivers unless no submessages matched'.
+!
+
+testMultiRewrite
+    | rewriter origTree match1 match2 |
+    match1 := RBParser parseExpression: 'x value'.
+    match2 := RBParser parseExpression: 'x'.
+    origTree := RBParser parseExpression: 'x value value'.
+
+    #(('`' '') ('' '`')) do: [:prefixes| | prefix1 prefix2 rewriter |
+ prefix1 := prefixes at: 1.
+ prefix2 := prefixes at: 2.
+ rewriter := ParseTreeRewriter new.
+ rewriter replace: prefix1 , '`@x value' with: prefix1 , '`@x';
+ replace: prefix2 , '`@x value' with: prefix2 , '`@x'.
+ rewriter executeTree: origTree copy.
+ self assert: ({match1. match2} contains: [:matchTree |
+    matchTree match: rewriter tree
+      inContext: RBSmallDictionary new])
+     description: 'Rewrite one or the other'].
+! !
+
+!TestStandardRewrites methodsFor: 'rewriting'!
+
+rewriterClass
+    ^ParseTreeRewriter
+!
+
+rewriting: codeTree with: rewriter yields: newCodeString
+    "Answer whether rewriting codeTree (untouched) with rewriter
+     yields newCodeString."
+    ^(RBParser parseExpression: newCodeString)
+ match: (rewriter executeTree: codeTree copy; tree)
+ inContext: RBSmallDictionary new
+!    
+
+rewrite: codeString from: pattern to: replacement
+    shouldBe: newCodeString
+    "Assert that replacing pattern with replacement in codeString
+     yields newCodeString."
+    ^self assert: ((RBParser parseRewriteExpression: newCodeString)
+       match: (self rewriterClass
+   replace: pattern
+   with: replacement
+   in: (RBParser parseExpression:
+    codeString))
+       inContext: Dictionary new)
+  description: ((WriteStream on: (String new: 50))
+    display: codeString; nl;
+    nextPutAll: '    ==| ('; print: pattern;
+    nextPutAll: ' => '; print: replacement;
+    nextPut: $); nl; nextPutAll: '    ==> ';
+    display: newCodeString; contents)
+! !
+
+Namespace current: STInST!


_______________________________________________
help-smalltalk mailing list
[hidden email]
http://lists.gnu.org/mailman/listinfo/help-smalltalk

On Tue, 2007-05-22 at 10:17 +0200, Paolo Bonzini wrote:
> -    newValue := oldContext at: key put: value "deepCopy <<<".
> +    newValue := oldContext at: key put: value deepCopy "<<<".

Quick postscript on this: I originally used `value collect: [:each |
each copy]' instead of deepCopy because value may be a node instead of a
list of nodes.  (RBProgramNode has 'collect: aBlock  ^aBlock value:
self'.)  So deepCopy copies the 'parent' instvar, which copies the value
and everything else in its tree.

The duplicate tree becomes garbage once the copied node is inserted back
into the original tree, but I thought it was worth avoiding anyway.  In
very rare cases, copying the parent's tree might cause problems with
rewriters computed under #recusivelySearchInContext.

--
;;; Stephen Compall ** http://scompall.nocandysw.com/blog **
Failure to imagine vast possibilities usually stems from a lack of
imagination, not a lack of possibility.

_______________________________________________
help-smalltalk mailing list
[hidden email]
http://lists.gnu.org/mailman/listinfo/help-smalltalk

Stephen Compall wrote:
> On Tue, 2007-05-22 at 10:17 +0200, Paolo Bonzini wrote:
>> -    newValue := oldContext at: key put: value "deepCopy <<<".
>> +    newValue := oldContext at: key put: value deepCopy "<<<".
>
> Quick postscript on this: I originally used `value collect: [:each |
> each copy]' instead of deepCopy because value may be a node instead of a
> list of nodes.  (RBProgramNode has 'collect: aBlock  ^aBlock value:
> self'.)  So deepCopy copies the 'parent' instvar, which copies the value
> and everything else in its tree.


Thanks for the explanation.  I added instead this one:

--- orig/compiler/RBParseNodes.st
+++ mod/compiler/RBParseNodes.st
@@ -253,6 +253,13 @@ nodesDo: aBlock

  !RBProgramNode methodsFor: 'enumeration'!

+deepCopy
+    "Hacked to fit collection protocols.  We use #deepCopy to obtain a list
+     of copied nodes.  We do already copy for our instance variables
+     through #postCopy, so we redirect #deepCopy to be a normal #copy."
+
+    ^self copy
+
  collect: aBlock
      "Hacked to fit collection protocols"


Thanks again for contributing these tests and bug fixes.  I will contact
other people I know that work on the refactoring browser in order to
have them merged.

Paolo



_______________________________________________
help-smalltalk mailing list
[hidden email]
http://lists.gnu.org/mailman/listinfo/help-smalltalk