Fix infinite loop in expander

[bpt/guile.git] / test-suite / tests / syncase.test

diff --git a/test-suite/tests/syncase.test b/test-suite/tests/syncase.test
index 6183df8..7651c46 100644 (file)
--- 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 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
@@ -22,6 +22,7 @@
 (define-module (test-suite test-syncase)
   #:use-module (test-suite lib)
   #:use-module (system base compile)
+  #:use-module (ice-9 regex)
   #:use-module ((srfi srfi-1) :select (member)))
 
 (define-syntax plus
@@ -115,16 +116,16 @@
          'foo)))
 
 (with-test-prefix "changes to expansion environment"
-  (pass-if "expander detects changes to current-module with @@"
+  (pass-if "expander detects changes to current-module with @@ @@"
     (compile '(begin
                 (define-module (new-module))
-                (@@ (new-module)
-                    (define-syntax new-module-macro
-                      (lambda (stx)
-                        (syntax-case stx () 
-                          ((_ arg) (syntax arg))))))
-                (@@ (new-module)
-                    (new-module-macro #t)))
+                (@@ @@ (new-module)
+                       (define-syntax new-module-macro
+                         (lambda (stx)
+                           (syntax-case stx () 
+                             ((_ arg) (syntax arg))))))
+                (@@ @@ (new-module)
+                       (new-module-macro #t)))
              #:env (current-module))))
 
 (define-module (test-suite test-syncase-2)
@@ -239,3 +240,85 @@
                  ((odd? x) (not (even? x)))))
              (even? 10))
           (current-module))))
+
+(define-module (test-suite test-syncase-3)
+  #:autoload (test-syncase-3-does-not-exist) (baz))
+
+(define-module (test-suite test-syncase)) ;; back to main module
+
+(pass-if "missing autoloads do not foil psyntax"
+  (parameterize ((current-warning-port (%make-void-port "w")))
+    (eval '(if #f (baz) #t)
+          (resolve-module '(test-suite test-syncase-3)))))
+
+(use-modules (system syntax))
+
+(with-test-prefix "syntax-local-binding"
+  (define-syntax syntax-type
+    (lambda (x)
+      (syntax-case x ()
+        ((_ id resolve?)
+         (call-with-values
+             (lambda ()
+               (syntax-local-binding
+                #'id
+                #:resolve-syntax-parameters? (syntax->datum #'resolve?)))
+           (lambda (type value)
+             (with-syntax ((type (datum->syntax #'id type)))
+               #''type)))))))
+
+  (define-syntax-parameter foo
+    (syntax-rules ()))
+
+  (pass-if "syntax-parameters (resolved)"
+    (equal? (syntax-type foo #t) 'macro))
+
+  (pass-if "syntax-parameters (unresolved)"
+    (equal? (syntax-type foo #f) 'syntax-parameter)))
+
+;; (put 'pass-if-syntax-error 'scheme-indent-function 1)
+(define-syntax pass-if-syntax-error
+  (syntax-rules ()
+    ((_ name pat exp)
+     (pass-if name
+       (catch 'syntax-error
+         (lambda () exp (error "expected syntax-error exception"))
+         (lambda (k who what where form . maybe-subform)
+           (if (if (pair? pat)
+                   (and (eq? who (car pat))
+                        (string-match (cdr pat) what))
+                   (string-match pat what))
+               #t
+               (error "unexpected syntax-error exception" what pat))))))))
+
+(with-test-prefix "primitives"
+  (pass-if-syntax-error "primref in default module"
+    "failed to match"
+    (macroexpand '(@@ primitive cons)))
+
+  (pass-if-syntax-error "primcall in default module"
+    "failed to match"
+    (macroexpand '((@@ primitive cons) 1 2)))
+
+  (pass-if-equal "primcall in (guile)"
+      '(1 . 2)
+      (@@ @@ (guile) ((@@ primitive cons) 1 2)))
+
+  (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))