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 eval_env (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 (eval_env (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 eval_env (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 (eval_env (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