summaryrefslogtreecommitdiff
path: root/test-suite/tests/syncase.test
blob: f3bb73b0758d32ca7a762237d19b215526a09300 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
;;;; syncase.test --- test suite for (ice-9 syncase)            -*- scheme -*-
;;;;
;;;; 	Copyright (C) 2001, 2006, 2009, 2010 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"
    (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))))