core: Add string-append.
[mes.git] / tests / macro.test
1 #! /bin/sh
2 # -*-scheme-*-
3 if [ "$MES" != guile ]; then
4     export MES_BOOT=boot-02.scm
5     MES=${MES-$(dirname $0)/../src/mes}
6     $MES < $0
7     exit $?
8 else
9     exit 0
10 fi
11 exec ${MES-mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests macro)' -s "$0" "$@"
12 !#
13
14 ;;; -*-scheme-*-
15
16 ;;; GNU Mes --- Maxwell Equations of Software
17 ;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
18 ;;;
19 ;;; This file is part of GNU Mes.
20 ;;;
21 ;;; GNU Mes is free software; you can redistribute it and/or modify it
22 ;;; under the terms of the GNU General Public License as published by
23 ;;; the Free Software Foundation; either version 3 of the License, or (at
24 ;;; your option) any later version.
25 ;;;
26 ;;; GNU Mes is distributed in the hope that it will be useful, but
27 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
28 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
29 ;;; GNU General Public License for more details.
30 ;;;
31 ;;; You should have received a copy of the GNU General Public License
32 ;;; along with GNU Mes.  If not, see <http://www.gnu.org/licenses/>.
33
34 (define-module (tests boot)
35   #:use-module (mes mes-0)
36   #:use-module (mes test))
37
38 (cond-expand
39  (mes
40   (primitive-load "module/mes/test.scm"))
41  (guile-2)
42  (guile
43   (use-modules (ice-9 syncase))))
44
45 (pass-if "first dummy" #t)
46 (pass-if-not "second dummy" #f)
47
48 (define gensym
49   ((lambda (symbols)
50      (lambda (. rest)
51        ((lambda (head tail)
52           (set! symbols tail)
53           head)
54         (car symbols)
55         (cdr symbols))))
56    '(g0 g1 g2 g3 g4)))
57
58 ;; type-0.mes
59 (define (string . lst)
60   (list->string lst))
61
62 ;; scm.mes
63 (define (symbol-append . rest)
64   (string->symbol (apply string-append (map symbol->string rest))))
65
66 (define-macro (make-fluid . default)
67   ((lambda (fluid)
68      (list
69       'begin
70       (list
71        'module-define!
72        (list 'boot-module)
73        (list 'quote fluid)
74        (list
75         (lambda (v)
76           (lambda ( . rest)
77             (if (null? rest) v
78                 (set! v (car rest)))))
79         (and (pair? default) (car default))))
80       (list 'quote fluid)))
81    (symbol-append 'fluid: (gensym))))
82
83 (define fluid (make-fluid 42))
84
85 (pass-if-eq "fluid" 42 (fluid))
86
87 (fluid 0)
88 (pass-if-eq "fluid 0" 0 (fluid))
89
90 (fluid '())
91 (pass-if-eq "fluid null" '() (fluid))
92
93 (define (fluid-ref fluid)
94   (fluid))
95
96 (define (fluid-set! fluid value)
97   (fluid value))
98
99 (fluid-set! fluid 0)
100 (pass-if-eq "fluid 0" 0 (fluid-ref fluid))
101
102 (fluid-set! fluid '())
103 (pass-if-eq "fluid null" '() (fluid-ref fluid))
104
105 (result 'report)