test-suite/tests/syncase.test

   1 ;;;; syncase.test --- test suite for (ice-9 syncase)            -*- scheme -*-
   2 ;;;;
   3 ;;;;    Copyright (C) 2001, 2006, 2009, 2010, 2011, 2013, 2015 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 (ice-9 regex)
  26   #:use-module ((srfi srfi-1) :select (member)))
  27
  28 (define-syntax plus
  29   (syntax-rules ()
  30     ((plus x ...) (+ x ...))))
  31
  32 (pass-if "basic syncase macro"
  33   (= (plus 1 2 3) (+ 1 2 3)))
  34
  35 (pass-if "@ works with syncase"
  36   (eq? run-test (@ (test-suite lib) run-test)))
  37
  38 (define-syntax string-let
  39   (lambda (stx)
  40     (syntax-case stx ()
  41       ((_ id body ...)
  42        #`(let ((id #,(symbol->string
  43                       (syntax->datum #'id))))
  44            body ...)))))
  45
  46 (pass-if "macro using quasisyntax"
  47   (equal? (string-let foo (list foo foo))
  48           '("foo" "foo")))
  49
  50 (define-syntax string-case
  51   (syntax-rules (else)
  52     ((string-case expr ((string ...) clause-body ...) ... (else else-body ...))
  53      (let ((value expr))
  54        (cond ((member value '(string ...) string=?)
  55               clause-body ...)
  56              ...
  57              (else
  58               else-body ...))))
  59     ((string-case expr ((string ...) clause-body ...) ...)
  60      (let ((value expr))
  61        (cond ((member value '(string ...) string=?)
  62               clause-body ...)
  63              ...)))))
  64
  65 (define-syntax alist
  66   (syntax-rules (tail)
  67     ((alist ((key val) ... (tail expr)))
  68      (cons* '(key . val) ... expr))
  69     ((alist ((key val) ...))
  70      (list '(key . val) ...))))
  71
  72 (with-test-prefix "with-syntax"
  73   (pass-if "definitions allowed in body"
  74     (equal? (with-syntax ((a 23))
  75               (define b #'a)
  76               (syntax->datum b))
  77             23)))
  78
  79 (with-test-prefix "tail patterns"
  80   (with-test-prefix "at the outermost level"
  81     (pass-if "non-tail invocation"
  82       (equal? (string-case "foo" (("foo") 'foo))
  83               'foo))
  84     (pass-if "tail invocation"
  85       (equal? (string-case "foo" (("bar") 'bar) (else 'else))
  86               'else)))
  87   (with-test-prefix "at a nested level"
  88     (pass-if "non-tail invocation"
  89       (equal? (alist ((a 1) (b 2) (c 3)))
  90               '((a . 1) (b . 2) (c . 3))))
  91     (pass-if "tail invocation"
  92       (equal? (alist ((foo 42) (tail '((bar . 66)))))
  93               '((foo . 42) (bar . 66))))))
  94
  95 (with-test-prefix "serializable labels and marks"
  96   (compile '(begin
  97               (define-syntax duplicate-macro
  98                 (syntax-rules ()
  99                   ((_ new-name old-name)
 100                    (define-syntax new-name
 101                      (syntax-rules ()
 102                        ((_ . vals)
 103                         (letrec-syntax ((apply (syntax-rules ()
 104                                                  ((_ macro args)
 105                                                   (macro . args)))))
 106                           (apply old-name vals))))))))
 107
 108               (define-syntax kwote
 109                 (syntax-rules ()
 110                   ((_ arg1) 'arg1)))
 111
 112               (duplicate-macro kwote* kwote))
 113            #:env (current-module))
 114   (pass-if "compiled macro-generating macro works"
 115     (eq? (eval '(kwote* foo) (current-module))
 116          'foo)))
 117
 118 (with-test-prefix "changes to expansion environment"
 119   (pass-if "expander detects changes to current-module with @@ @@"
 120     (compile '(begin
 121                 (define-module (new-module))
 122                 (@@ @@ (new-module)
 123                        (define-syntax new-module-macro
 124                          (lambda (stx)
 125                            (syntax-case stx ()
 126                              ((_ arg) (syntax arg))))))
 127                 (@@ @@ (new-module)
 128                        (new-module-macro #t)))
 129              #:env (current-module))))
 130
 131 (define-module (test-suite test-syncase-2)
 132   #:export (make-the-macro))
 133
 134 (define (hello)
 135   'hello)
 136
 137 (define-syntax make-the-macro
 138   (syntax-rules ()
 139     ((_ name)
 140      (define-syntax name
 141        (syntax-rules ()
 142          ((_) (hello)))))))
 143
 144 (define-module (test-suite test-syncase)) ;; back to main module
 145 (use-modules (test-suite test-syncase-2))
 146
 147 (make-the-macro foo)
 148
 149 (with-test-prefix "macro-generating macro"
 150   (pass-if "module hygiene"
 151     (eq? (foo) 'hello)))
 152
 153 (pass-if "_ is a placeholder"
 154   (equal? (eval '(begin
 155                    (define-syntax ciao
 156                      (lambda (stx)
 157                        (syntax-case stx ()
 158                          ((_ _)
 159                           "ciao"))))
 160                    (ciao 1))
 161                 (current-module))
 162           "ciao"))
 163
 164 (define qux 30)
 165
 166 (with-test-prefix "identifier-syntax"
 167
 168   (pass-if "global reference"
 169     (let-syntax ((baz (identifier-syntax qux)))
 170       (equal? baz qux)))
 171
 172   (pass-if "lexical hygienic reference"
 173     (let-syntax ((baz (identifier-syntax qux)))
 174       (let ((qux 20))
 175         (equal? (+ baz qux)
 176                 50))))
 177
 178   (pass-if "lexical hygienic reference (bound)"
 179     (let ((qux 20))
 180       (let-syntax ((baz (identifier-syntax qux)))
 181         (equal? (+ baz qux)
 182                 40))))
 183
 184   (pass-if "global reference (settable)"
 185     (let-syntax ((baz (identifier-syntax
 186                        (id qux)
 187                        ((set! id expr) (set! qux expr)))))
 188       (equal? baz qux)))
 189
 190   (pass-if "lexical hygienic reference (settable)"
 191     (let-syntax ((baz (identifier-syntax
 192                        (id qux)
 193                        ((set! id expr) (set! qux expr)))))
 194       (let ((qux 20))
 195         (equal? (+ baz qux)
 196                 50))))
 197
 198   (pass-if "lexical hygienic reference (bound, settable)"
 199     (let ((qux 20))
 200       (let-syntax ((baz (identifier-syntax
 201                          (id qux)
 202                          ((set! id expr) (set! qux expr)))))
 203         (equal? (+ baz qux)
 204                 40))))
 205
 206   (pass-if "global set!"
 207     (let-syntax ((baz (identifier-syntax
 208                        (id qux)
 209                        ((set! id expr) (set! qux expr)))))
 210       (set! baz 10)
 211       (equal? (+ baz qux) 20)))
 212
 213   (pass-if "lexical hygienic set!"
 214     (let-syntax ((baz (identifier-syntax
 215                        (id qux)
 216                        ((set! id expr) (set! qux expr)))))
 217       (and (let ((qux 20))
 218              (set! baz 5)
 219              (equal? (+ baz qux)
 220                      25))
 221            (equal? qux 5))))
 222
 223   (pass-if "lexical hygienic set! (bound)"
 224     (let ((qux 20))
 225       (let-syntax ((baz (identifier-syntax
 226                          (id qux)
 227                          ((set! id expr) (set! qux expr)))))
 228         (set! baz 50)
 229         (equal? (+ baz qux)
 230                 100)))))
 231
 232 (with-test-prefix "top-level expansions"
 233   (pass-if "syntax definitions expanded before other expressions"
 234     (eval '(begin
 235              (define even?
 236                (lambda (x)
 237                  (or (= x 0) (odd? (- x 1)))))
 238              (define-syntax odd?
 239                (syntax-rules ()
 240                  ((odd? x) (not (even? x)))))
 241              (even? 10))
 242           (current-module))))
 243
 244 (define-module (test-suite test-syncase-3)
 245   #:autoload (test-syncase-3-does-not-exist) (baz))
 246
 247 (define-module (test-suite test-syncase)) ;; back to main module
 248
 249 (pass-if "missing autoloads do not foil psyntax"
 250   (parameterize ((current-warning-port (%make-void-port "w")))
 251     (eval '(if #f (baz) #t)
 252           (resolve-module '(test-suite test-syncase-3)))))
 253
 254 (use-modules (system syntax))
 255
 256 (with-test-prefix "syntax-local-binding"
 257   (define-syntax syntax-type
 258     (lambda (x)
 259       (syntax-case x ()
 260         ((_ id resolve?)
 261          (call-with-values
 262              (lambda ()
 263                (syntax-local-binding
 264                 #'id
 265                 #:resolve-syntax-parameters? (syntax->datum #'resolve?)))
 266            (lambda (type value)
 267              (with-syntax ((type (datum->syntax #'id type)))
 268                #''type)))))))
 269
 270   (define-syntax-parameter foo
 271     (syntax-rules ()))
 272
 273   (pass-if "syntax-parameters (resolved)"
 274     (equal? (syntax-type foo #t) 'macro))
 275
 276   (pass-if "syntax-parameters (unresolved)"
 277     (equal? (syntax-type foo #f) 'syntax-parameter)))
 278
 279 ;; (put 'pass-if-syntax-error 'scheme-indent-function 1)
 280 (define-syntax pass-if-syntax-error
 281   (syntax-rules ()
 282     ((_ name pat exp)
 283      (pass-if name
 284        (catch 'syntax-error
 285          (lambda () exp (error "expected syntax-error exception"))
 286          (lambda (k who what where form . maybe-subform)
 287            (if (if (pair? pat)
 288                    (and (eq? who (car pat))
 289                         (string-match (cdr pat) what))
 290                    (string-match pat what))
 291                #t
 292                (error "unexpected syntax-error exception" what pat))))))))
 293
 294 (with-test-prefix "primitives"
 295   (pass-if-syntax-error "primref in default module"
 296     "failed to match"
 297     (macroexpand '(@@ primitive cons)))
 298
 299   (pass-if-syntax-error "primcall in default module"
 300     "failed to match"
 301     (macroexpand '((@@ primitive cons) 1 2)))
 302
 303   (pass-if-equal "primcall in (guile)"
 304       '(1 . 2)
 305       (@@ @@ (guile) ((@@ primitive cons) 1 2)))
 306
 307   (pass-if-syntax-error "primref in (guile)"
 308     "not in operator position"
 309     (macroexpand '(@@ @@ (guile) (@@ primitive cons)))))
 310
 311 (pass-if "infinite loop bug"
 312   (begin
 313     (macroexpand
 314      '(let-syntax
 315           ((define-foo
 316              (syntax-rules ()
 317                ((define-foo a b)
 318                 (begin
 319                   (define a '())
 320                   ;; Oddly, the "*" in the define* seems to be
 321                   ;; important in triggering this bug.
 322                   (define* (b) (set! a a)))))))
 323         (define-foo a c)))
 324     #t))