[Help-smalltalk] last tests patch for a while -- ParseTreeRewriter

[Paolo Bonzini]

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

Paolo

2007-05-22  Stephen Compall  <address@hidden>
            Paolo Bonzini  <address@hidden>

        * 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: 'address@hidden isNil ifTrue: [|address@hidden| address@hidden
+                                 ifFalse: address@hidden'
+        to: 'address@hidden ifNil: [|address@hidden| address@hidden'
+        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'
+        "address@hidden 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: 'address@hidden at: address@hidden put: address@hidden'
+        to: 'address@hidden set: address@hidden to: address@hidden'
+        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: 'address@hidden display: address@hidden'
+        to: 'address@hidden'
+        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: 'address@hidden display: address@hidden'
+        to: 'address@hidden display: address@hidden; 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: 'address@hidden display: address@hidden'
+        to: 'address@hidden'
+        shouldBe: 'qqq display: [sss];
+                       display: [[sss]]'.
+    [| rsicCopiesPRewriter sourceExp |
+     rsicCopiesPRewriter := self rewriterClass new
+          replace: 'address@hidden display: address@hidden' with: 
'address@hidden';
+          replace: 'address@hidden value' with: 'address@hidden';
+          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: 'address@hidden a'
+                        with: 'address@hidden 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 , 'address@hidden value' with: prefix1 , 
'address@hidden';
+       replace: prefix2 , 'address@hidden value' with: prefix2 , 
'address@hidden'.
+       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!