Finalize psyntax integration.
[mes.git] / tests / psyntax.test
1 #! /bin/sh
2 # -*-scheme-*-
3 echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/../scripts/mes "$@"
4 #paredit:||
5 exit $?
6 !#
7
8 ;;; -*-scheme-*-
9
10 ;;; Mes --- Maxwell Equations of Software
11 ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
12 ;;;
13 ;;; This file is part of Mes.
14 ;;;
15 ;;; Mes is free software; you can redistribute it and/or modify it
16 ;;; under the terms of the GNU General Public License as published by
17 ;;; the Free Software Foundation; either version 3 of the License, or (at
18 ;;; your option) any later version.
19 ;;;
20 ;;; Mes is distributed in the hope that it will be useful, but
21 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
22 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
23 ;;; GNU General Public License for more details.
24 ;;;
25 ;;; You should have received a copy of the GNU General Public License
26 ;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
27
28 (mes-use-module (mes base-0))
29 (mes-use-module (mes base))
30 (mes-use-module (mes quasiquote))
31 (mes-use-module (mes let))
32 (mes-use-module (srfi srfi-0))
33 (mes-use-module (mes scm))
34 (mes-use-module (mes psyntax-0))
35 (mes-use-module (mes psyntax-pp))
36 (mes-use-module (mes psyntax-1))
37 (mes-use-module (mes test))
38
39 (pass-if "first dummy" #t)
40 (pass-if-not "second dummy" #f)
41
42 (cond-expand
43  (guile
44   ;;(use-modules (ice-9 syncase))
45   (define sc-expand identity)
46   (define syntax-object->datum syntax->datum)
47   (define datum->syntax-object datum->syntax)
48   )
49  (mes))
50
51 (when (not guile?)
52  (pass-if "andmap"
53    (seq? (andmap (lambda (x) (> x 0)) '(3 2 1)) #t))
54
55  (pass-if "andmap 2"
56    (seq? (andmap (lambda (x) (> x 0)) '(3 2 1 0)) #f))
57
58  (pass-if "putprop" (putprop 'foo '*sc-expander 'bar))
59
60  (pass-if "getprop"
61    (seq? (getprop 'foo '*sc-expander) 'bar))
62  )
63
64 (pass-if "syntax-case"
65   (sequal? (let* ((sexp '(syntax-case '((1 2) (3 4)) ()
66                            (((x ...) ...) (syntax (x ... ...)))))
67                   (expanded (sc-expand sexp)))
68              (primitive-eval expanded))
69            '(1 2 3 4)))
70
71 (pass-if "sc-expand"
72   (sequal? (let ()
73              (syntax-case '((1 2) (3 4)) ()
74                (((x ...) ...) (syntax (x ... ...)))))
75            '(1 2 3 4)))
76
77 (pass-if "syntax-object->datum"
78   (sequal? (syntax-object->datum (syntax (set! a b)))
79            '(set! a b)))
80
81 (pass-if "syntax-case swap!"
82   (sequal? (syntax-object->datum
83             (let ((exp '(set! a b)))
84               (syntax-case exp ()
85                 ((swap! a b)
86                  (syntax
87                   (let ((temp a))
88                     (set! a b)
89                     (set! b temp)))))))
90            '(let ((temp a)) (set! a b) (set! b temp))))
91
92 (when (not guile?)
93   (pass-if "syntax-case manual swap!"
94     (sequal?
95      (let* ((sc (sc-expand '(syntax-case exp () ((swap! a b) (syntax (let ((temp a)) (set! a b) (set! b temp)))))))
96             (exp '(swap foo bar))
97             (foo "foo")
98             (bar "bar")
99             (s (eval sc (current-module)))
100             (d (syntax-object->datum s)))
101        (eval d (current-module))
102        (list foo bar))
103      '("bar" "foo"))))
104
105 (pass-if "define-syntax swap! [syntax-case]"
106   (sequal?
107    (let ()
108      (define-syntax swap!
109        (lambda (exp)
110          (syntax-case exp ()
111            ((swap! a b)
112             (syntax
113              ((lambda (temp)
114                 (set! a b)
115                 (set! b temp)) a))))))
116      (let ((foo "foo")
117            (bar "bar"))
118        (swap! foo bar)
119        (list foo bar)))
120    (list "bar" "foo")))
121
122 (pass-if "define-syntax swap! [syntax-case+let]"
123   (sequal?
124    (let ()
125      (define-syntax swap!
126        (lambda (exp)
127          (syntax-case exp ()
128            ((swap! a b)
129             (syntax
130              (let ((temp a))
131                (set! a b)
132                (set! b temp)))))))
133      (let ((foo "foo")
134            (bar "bar"))
135        (swap! foo bar)
136        (list foo bar)))
137    (list "bar" "foo")))
138
139 (pass-if "define-syntax sr:when [syntax-rules]"
140   (sequal?
141    (let ()
142      (define-syntax sr:when
143        (syntax-rules ()
144          ((sc:when condition exp ...)
145           (if condition
146               (begin exp ...)))))
147      (let ()
148        (sr:when #t "if not now, then?")))
149    "if not now, then?"))
150
151 (pass-if "define-syntax-rule"
152   (sequal?
153    (let ()
154      (define-syntax-rule (sre:when c e ...)
155        (if c (begin e ...)))
156      (let ()
157        (sre:when #t "if not now, then?")))
158    "if not now, then?"))
159
160 (pass-if-equal "syntax-rules plus"
161     (+ 1 2 3)
162   (let ()
163     (define-syntax plus
164       (syntax-rules ()
165         ((plus x ...) (+ x ...))))
166     (plus 1 2 3)))
167
168 (when guile?
169   (pass-if-equal "macro with quasisyntax"
170       '("foo" "foo")
171     (let ()
172       (define-syntax string-let
173         (lambda (stx)
174           (syntax-case stx ()
175             ((_ id body ...)
176              #`(let ((id #,(symbol->string (syntax->datum #'id))))
177                  body ...)))))
178       (string-let foo (list foo foo)))))
179
180 (result 'report)