;;;; syncase.test --- test suite for (ice-9 syncase)            -*- scheme -*-
;;;;
;;;; 	Copyright (C) 2001, 2006, 2009 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
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;; 
;;;; This 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 this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;; These tests are in a module so that the syntax transformer does not
;; affect code outside of this file.
;;
(define-module (test-suite test-syncase)
  #:use-module (test-suite lib)
  #:use-module (system base compile)
  #:use-module ((srfi srfi-1) :select (member)))

(define-syntax plus
  (syntax-rules ()
    ((plus x ...) (+ x ...))))

(pass-if "basic syncase macro"
  (= (plus 1 2 3) (+ 1 2 3)))

(pass-if "@ works with syncase"
  (eq? run-test (@ (test-suite lib) run-test)))

(define-syntax string-let
  (lambda (stx)
    (syntax-case stx ()
      ((_ id body ...)
       #`(let ((id #,(symbol->string
                      (syntax->datum #'id))))
           body ...)))))

(pass-if "macro using quasisyntax"
  (equal? (string-let foo (list foo foo))
          '("foo" "foo")))

(define-syntax string-case
  (syntax-rules (else)
    ((string-case expr ((string ...) clause-body ...) ... (else else-body ...))
     (let ((value expr))
       (cond ((member value '(string ...) string=?)
              clause-body ...)
             ...
             (else
              else-body ...))))
    ((string-case expr ((string ...) clause-body ...) ...)
     (let ((value expr))
       (cond ((member value '(string ...) string=?)
              clause-body ...)
             ...)))))

(define-syntax alist
  (syntax-rules (tail)
    ((alist ((key val) ... (tail expr)))
     (cons* '(key . val) ... expr))
    ((alist ((key val) ...))
     (list '(key . val) ...))))

(with-test-prefix "tail patterns"
  (with-test-prefix "at the outermost level"
    (pass-if "non-tail invocation"
      (equal? (string-case "foo" (("foo") 'foo))
              'foo))
    (pass-if "tail invocation"
      (equal? (string-case "foo" (("bar") 'bar) (else 'else))
              'else)))
  (with-test-prefix "at a nested level"
    (pass-if "non-tail invocation"
      (equal? (alist ((a 1) (b 2) (c 3)))
              '((a . 1) (b . 2) (c . 3))))
    (pass-if "tail invocation"
      (equal? (alist ((foo 42) (tail '((bar . 66)))))
              '((foo . 42) (bar . 66))))))

(with-test-prefix "serializable labels and marks"
  (compile '(begin
              (define-syntax duplicate-macro
                (syntax-rules ()
                  ((_ new-name old-name)
                   (define-syntax new-name
                     (syntax-rules ()
                       ((_ . vals)
                        (letrec-syntax ((apply (syntax-rules ()
                                                 ((_ macro args)
                                                  (macro . args)))))
                          (apply old-name vals))))))))

              (define-syntax kwote
                (syntax-rules ()
                  ((_ arg1) 'arg1)))

              (duplicate-macro kwote* kwote))
           #:env (current-module))
  (pass-if "compiled macro-generating macro works"
    (eq? (eval '(kwote* foo) (current-module))
         'foo)))

(with-test-prefix "changes to expansion environment"
  (pass-if "expander detects changes to current-module"
    (or (false-if-exception
	 (compile '(begin
		     (define-module (new-module))
		     (define-syntax new-module-macro
		       (lambda (stx)
			 (syntax-case stx () 
			   ((_ arg) (syntax arg)))))
		     (new-module-macro #t))
		  #:env (current-module)))
	(throw 'unresolved))))