test-suite/tests/syncase.test

   1 ;;;; syncase.test --- test suite for (ice-9 syncase)            -*- scheme -*-
   2 ;;;;
   3 ;;;;    Copyright (C) 2001, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
   4 ;;;;
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 ;; These tests are in a module so that the syntax transformer does not
  20 ;; affect code outside of this file.
  21 ;;
  22 (define-module (test-suite test-syncase)
  23   #:use-module (test-suite lib)
  24   #:use-module (system base compile)
  25   #:use-module ((srfi srfi-1) :select (member)))
  26
  27 (define-syntax plus
  28   (syntax-rules ()
  29     ((plus x ...) (+ x ...))))
  30
  31 (pass-if "basic syncase macro"
  32   (= (plus 1 2 3) (+ 1 2 3)))
  33
  34 (pass-if "@ works with syncase"
  35   (eq? run-test (@ (test-suite lib) run-test)))
  36
  37 (define-syntax string-let
  38   (lambda (stx)
  39     (syntax-case stx ()
  40       ((_ id body ...)
  41        #`(let ((id #,(symbol->string
  42                       (syntax->datum #'id))))
  43            body ...)))))
  44
  45 (pass-if "macro using quasisyntax"
  46   (equal? (string-let foo (list foo foo))
  47           '("foo" "foo")))
  48
  49 (define-syntax string-case
  50   (syntax-rules (else)
  51     ((string-case expr ((string ...) clause-body ...) ... (else else-body ...))
  52      (let ((value expr))
  53        (cond ((member value '(string ...) string=?)
  54               clause-body ...)
  55              ...
  56              (else
  57               else-body ...))))
  58     ((string-case expr ((string ...) clause-body ...) ...)
  59      (let ((value expr))
  60        (cond ((member value '(string ...) string=?)
  61               clause-body ...)
  62              ...)))))
  63
  64 (define-syntax alist
  65   (syntax-rules (tail)
  66     ((alist ((key val) ... (tail expr)))
  67      (cons* '(key . val) ... expr))
  68     ((alist ((key val) ...))
  69      (list '(key . val) ...))))
  70
  71 (with-test-prefix "with-syntax"
  72   (pass-if "definitions allowed in body"
  73     (equal? (with-syntax ((a 23))
  74               (define b #'a)
  75               (syntax->datum b))
  76             23)))
  77
  78 (with-test-prefix "tail patterns"
  79   (with-test-prefix "at the outermost level"
  80     (pass-if "non-tail invocation"
  81       (equal? (string-case "foo" (("foo") 'foo))
  82               'foo))
  83     (pass-if "tail invocation"
  84       (equal? (string-case "foo" (("bar") 'bar) (else 'else))
  85               'else)))
  86   (with-test-prefix "at a nested level"
  87     (pass-if "non-tail invocation"
  88       (equal? (alist ((a 1) (b 2) (c 3)))
  89               '((a . 1) (b . 2) (c . 3))))
  90     (pass-if "tail invocation"
  91       (equal? (alist ((foo 42) (tail '((bar . 66)))))
  92               '((foo . 42) (bar . 66))))))
  93
  94 (with-test-prefix "serializable labels and marks"
  95   (compile '(begin
  96               (define-syntax duplicate-macro
  97                 (syntax-rules ()
  98                   ((_ new-name old-name)
  99                    (define-syntax new-name
 100                      (syntax-rules ()
 101                        ((_ . vals)
 102                         (letrec-syntax ((apply (syntax-rules ()
 103                                                  ((_ macro args)
 104                                                   (macro . args)))))
 105                           (apply old-name vals))))))))
 106
 107               (define-syntax kwote
 108                 (syntax-rules ()
 109                   ((_ arg1) 'arg1)))
 110
 111               (duplicate-macro kwote* kwote))
 112            #:env (current-module))
 113   (pass-if "compiled macro-generating macro works"
 114     (eq? (eval '(kwote* foo) (current-module))
 115          'foo)))
 116
 117 (with-test-prefix "changes to expansion environment"
 118   (pass-if "expander detects changes to current-module with @@ @@"
 119     (compile '(begin
 120                 (define-module (new-module))
 121                 (@@ @@ (new-module)
 122                        (define-syntax new-module-macro
 123                          (lambda (stx)
 124                            (syntax-case stx ()
 125                              ((_ arg) (syntax arg))))))
 126                 (@@ @@ (new-module)
 127                        (new-module-macro #t)))
 128              #:env (current-module))))
 129
 130 (define-module (test-suite test-syncase-2)
 131   #:export (make-the-macro))
 132
 133 (define (hello)
 134   'hello)
 135
 136 (define-syntax make-the-macro
 137   (syntax-rules ()
 138     ((_ name)
 139      (define-syntax name
 140        (syntax-rules ()
 141          ((_) (hello)))))))
 142
 143 (define-module (test-suite test-syncase)) ;; back to main module
 144 (use-modules (test-suite test-syncase-2))
 145
 146 (make-the-macro foo)
 147
 148 (with-test-prefix "macro-generating macro"
 149   (pass-if "module hygiene"
 150     (eq? (foo) 'hello)))
 151
 152 (pass-if "_ is a placeholder"
 153   (equal? (eval '(begin
 154                    (define-syntax ciao
 155                      (lambda (stx)
 156                        (syntax-case stx ()
 157                          ((_ _)
 158                           "ciao"))))
 159                    (ciao 1))
 160                 (current-module))
 161           "ciao"))
 162
 163 (define qux 30)
 164
 165 (with-test-prefix "identifier-syntax"
 166
 167   (pass-if "global reference"
 168     (let-syntax ((baz (identifier-syntax qux)))
 169       (equal? baz qux)))
 170
 171   (pass-if "lexical hygienic reference"
 172     (let-syntax ((baz (identifier-syntax qux)))
 173       (let ((qux 20))
 174         (equal? (+ baz qux)
 175                 50))))
 176
 177   (pass-if "lexical hygienic reference (bound)"
 178     (let ((qux 20))
 179       (let-syntax ((baz (identifier-syntax qux)))
 180         (equal? (+ baz qux)
 181                 40))))
 182
 183   (pass-if "global reference (settable)"
 184     (let-syntax ((baz (identifier-syntax
 185                        (id qux)
 186                        ((set! id expr) (set! qux expr)))))
 187       (equal? baz qux)))
 188
 189   (pass-if "lexical hygienic reference (settable)"
 190     (let-syntax ((baz (identifier-syntax
 191                        (id qux)
 192                        ((set! id expr) (set! qux expr)))))
 193       (let ((qux 20))
 194         (equal? (+ baz qux)
 195                 50))))
 196
 197   (pass-if "lexical hygienic reference (bound, settable)"
 198     (let ((qux 20))
 199       (let-syntax ((baz (identifier-syntax
 200                          (id qux)
 201                          ((set! id expr) (set! qux expr)))))
 202         (equal? (+ baz qux)
 203                 40))))
 204
 205   (pass-if "global set!"
 206     (let-syntax ((baz (identifier-syntax
 207                        (id qux)
 208                        ((set! id expr) (set! qux expr)))))
 209       (set! baz 10)
 210       (equal? (+ baz qux) 20)))
 211
 212   (pass-if "lexical hygienic set!"
 213     (let-syntax ((baz (identifier-syntax
 214                        (id qux)
 215                        ((set! id expr) (set! qux expr)))))
 216       (and (let ((qux 20))
 217              (set! baz 5)
 218              (equal? (+ baz qux)
 219                      25))
 220            (equal? qux 5))))
 221
 222   (pass-if "lexical hygienic set! (bound)"
 223     (let ((qux 20))
 224       (let-syntax ((baz (identifier-syntax
 225                          (id qux)
 226                          ((set! id expr) (set! qux expr)))))
 227         (set! baz 50)
 228         (equal? (+ baz qux)
 229                 100)))))
 230
 231 (with-test-prefix "top-level expansions"
 232   (pass-if "syntax definitions expanded before other expressions"
 233     (eval '(begin
 234              (define even?
 235                (lambda (x)
 236                  (or (= x 0) (odd? (- x 1)))))
 237              (define-syntax odd?
 238                (syntax-rules ()
 239                  ((odd? x) (not (even? x)))))
 240              (even? 10))
 241           (current-module))))