core: Add compile time switch for quasisyntax.
[mes.git] / quasiquote.c
1 /* -*-comment-start: "//";comment-end:""-*-
2  * Mes --- Maxwell Equations of Software
3  * Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
4  *
5  * This file is part of Mes.
6  *
7  * Mes is free software; you can redistribute it and/or modify it
8  * under the terms of the GNU General Public License as published by
9  * the Free Software Foundation; either version 3 of the License, or (at
10  * your option) any later version.
11  *
12  * Mes is distributed in the hope that it will be useful, but
13  * WITHOUT ANY WARRANTY; without even the implied warranty of
14  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15  * GNU General Public License for more details.
16  *
17  * You should have received a copy of the GNU General Public License
18  * along with Mes.  If not, see <http://www.gnu.org/licenses/>.
19  */
20
21 #if QUASIQUOTE
22 scm *add_environment (scm *a, char const *name, scm *x);
23
24 scm *
25 unquote (scm *x) ///((no-environment))
26 {
27   return cons (&symbol_unquote, x);
28 }
29
30 scm *
31 unquote_splicing (scm *x) ///((no-environment))
32 {
33   return cons (&symbol_unquote_splicing, x);
34 }
35
36 scm *
37 eval_quasiquote (scm *e, scm *a)
38 {
39   if (e == &scm_nil) return e;
40   else if (atom_p (e) == &scm_t) return e;
41   else if (eq_p (car (e), &symbol_unquote) == &scm_t)
42     return builtin_eval (cadr (e), a);
43   else if (e->type == PAIR && e->car->type == PAIR
44            && eq_p (caar (e), &symbol_unquote_splicing) == &scm_t)
45       return append2 (builtin_eval (cadar (e), a), eval_quasiquote (cdr (e), a));
46   return cons (eval_quasiquote (car (e), a), eval_quasiquote (cdr (e), a));
47 }
48
49 scm *
50 the_unquoters = &scm_nil;
51
52 scm *
53 add_unquoters (scm *a)
54 {
55   if (the_unquoters == &scm_nil)
56     the_unquoters = cons (cons (&symbol_unquote, &scm_unquote),
57                           cons (cons (&symbol_unquote_splicing, &scm_unquote_splicing),
58                                 &scm_nil));
59   return append2 (the_unquoters, a);
60 }
61 #else // !QUASIQUOTE
62
63 scm*add_unquoters (scm *a){}
64 scm*eval_quasiquote (scm *e, scm *a){}
65
66 #endif // QUASIQUOTE
67
68 #if QUASISYNTAX
69 scm *
70 syntax (scm *x)
71 {
72   return cons (&symbol_syntax, x);
73 }
74
75 scm *
76 unsyntax (scm *x) ///((no-environment))
77 {
78   return cons (&symbol_unsyntax, x);
79 }
80
81 scm *
82 unsyntax_splicing (scm *x) ///((no-environment))
83 {
84   return cons (&symbol_unsyntax_splicing, x);
85 }
86
87 scm *
88 eval_quasisyntax (scm *e, scm *a)
89 {
90   if (e == &scm_nil) return e;
91   else if (atom_p (e) == &scm_t) return e;
92   else if (eq_p (car (e), &symbol_unsyntax) == &scm_t)
93     return builtin_eval (cadr (e), a);
94   else if (e->type == PAIR && e->car->type == PAIR
95            && eq_p (caar (e), &symbol_unsyntax_splicing) == &scm_t)
96       return append2 (builtin_eval (cadar (e), a), eval_quasisyntax (cdr (e), a));
97   return cons (eval_quasisyntax (car (e), a), eval_quasisyntax (cdr (e), a));
98 }
99
100 scm *
101 add_unsyntaxers (scm *a)
102 {
103   a = cons (cons (&symbol_unsyntax, &scm_unsyntax), a);
104   a = cons (cons (&symbol_unsyntax_splicing, &scm_unsyntax_splicing), a);
105   return a;
106 }
107
108 #else // !QUASISYNTAX
109 scm*syntax (scm *x){}
110 scm*unsyntax (scm *x){}
111 scm*unsyntax_splicing (scm *x){}
112 scm*add_unsyntaxers (scm *a){}
113 scm*eval_unsyntax (scm *e, scm *a){}
114 scm*eval_quasisyntax (scm *e, scm *a){}
115
116 #endif // !QUASISYNTAX