[Guile-commits] 01/01: Fix infinite loop in expander

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 37ae02ffa0d788f59c096cec7a3ac9744d87cf16
Author: Andy Wingo <address@hidden>
Date:   Fri Feb 13 16:40:46 2015 +0100

    Fix infinite loop in expander
    
    * module/ice-9/psyntax.scm (resolve-identifier): There is a case where a
      syntax object can resolve to itself.  Prevent an infinite loop in that
      case by continuing to resolve by name.
    
    * module/ice-9/psyntax-pp.scm: Regenerate.
    
    * test-suite/tests/syncase.test ("infinite loop bug"): Add a test.
---
 module/ice-9/psyntax-pp.scm   |    9 ++++++++-
 module/ice-9/psyntax.scm      |   19 +++++++++++++++----
 test-suite/tests/syncase.test |   17 ++++++++++++++++-
 3 files changed, 39 insertions(+), 6 deletions(-)

diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index 7ad8a70..6029f05 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -463,7 +463,14 @@
                 (values (car b) (cdr b) mod)))))
          (let ((n (id-var-name id w mod)))
            (cond ((syntax-object? n)
-                  (resolve-identifier n w r mod resolve-syntax-parameters?))
+                  (if (not (eq? n id))
+                    (resolve-identifier n w r mod resolve-syntax-parameters?)
+                    (resolve-identifier
+                      (syntax-object-expression n)
+                      (syntax-object-wrap n)
+                      r
+                      (syntax-object-module n)
+                      resolve-syntax-parameters?)))
                  ((symbol? n)
                   (resolve-global
                     n
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index f7c5c0e..c9c309a 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -1,7 +1,7 @@
 ;;;; -*-scheme-*-
 ;;;;
 ;;;; Copyright (C) 2001, 2003, 2006, 2009, 2010, 2011,
-;;;;   2012, 2013 Free Software Foundation, Inc.
+;;;;   2012, 2013, 2015 Free Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -890,9 +890,20 @@
       (let ((n (id-var-name id w mod)))
         (cond
          ((syntax-object? n)
-          ;; Recursing allows syntax-parameterize to override
-          ;; macro-introduced syntax parameters.
-          (resolve-identifier n w r mod resolve-syntax-parameters?))
+          (cond
+           ((not (eq? n id))
+            ;; This identifier aliased another; recurse to allow
+            ;; syntax-parameterize to override macro-introduced syntax
+            ;; parameters.
+            (resolve-identifier n w r mod resolve-syntax-parameters?))
+           (else
+            ;; Resolved to a free variable that was introduced by this
+            ;; macro; continue to resolve this global by name.
+            (resolve-identifier (syntax-object-expression n)
+                                (syntax-object-wrap n)
+                                r
+                                (syntax-object-module n)
+                                resolve-syntax-parameters?))))
          ((symbol? n)
           (resolve-global n (if (syntax-object? id)
                                 (syntax-object-module id)
diff --git a/test-suite/tests/syncase.test b/test-suite/tests/syncase.test
index 15c811c..7651c46 100644
--- a/test-suite/tests/syncase.test
+++ b/test-suite/tests/syncase.test
@@ -1,6 +1,6 @@
 ;;;; syncase.test --- test suite for (ice-9 syncase)            -*- scheme -*-
 ;;;;
-;;;;   Copyright (C) 2001, 2006, 2009, 2010, 2011, 2013 Free Software 
Foundation, Inc.
+;;;;   Copyright (C) 2001, 2006, 2009, 2010, 2011, 2013, 2015 Free Software 
Foundation, Inc.
 ;;;; 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -307,3 +307,18 @@
   (pass-if-syntax-error "primref in (guile)"
     "not in operator position"
     (macroexpand '(@@ @@ (guile) (@@ primitive cons)))))
+
+(pass-if "infinite loop bug"
+  (begin
+    (macroexpand
+     '(let-syntax
+          ((define-foo
+             (syntax-rules ()
+               ((define-foo a b)
+                (begin
+                  (define a '())
+                  ;; Oddly, the "*" in the define* seems to be
+                  ;; important in triggering this bug.
+                  (define* (b) (set! a a)))))))
+        (define-foo a c)))
+    #t))