lily/simple-closure.cc

   1 /*
   2   This file is part of LilyPond, the GNU music typesetter.
   3
   4   Copyright (C) 2005--2014 Han-Wen Nienhuys <hanwen@xs4all.nl>
   5
   6
   7   LilyPond is free software: you can redistribute it and/or modify
   8   it under the terms of the GNU General Public License as published by
   9   the Free Software Foundation, either version 3 of the License, or
  10   (at your option) any later version.
  11
  12   LilyPond is distributed in the hope that it will be useful,
  13   but 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 LilyPond.  If not, see <http://www.gnu.org/licenses/>.
  19 */
  20 #include "simple-closure.hh"
  21 #include "unpure-pure-container.hh"
  22
  23 #include "grob.hh"
  24
  25 static scm_t_bits simple_closure_tag;
  26
  27 bool
  28 is_simple_closure (SCM s)
  29 {
  30   return (SCM_NIMP (s) && SCM_CELL_TYPE (s) == simple_closure_tag);
  31 }
  32
  33 SCM
  34 simple_closure_expression (SCM smob)
  35 {
  36   assert (is_simple_closure (smob));
  37   return (SCM) SCM_CELL_WORD_1 (smob);
  38 }
  39
  40 SCM
  41 evaluate_args (SCM delayed_argument, SCM args, bool pure, int start, int end)
  42 {
  43   SCM new_args = SCM_EOL;
  44   SCM *tail = &new_args;
  45   for (SCM s = args; scm_is_pair (s); s = scm_cdr (s))
  46     {
  47       *tail = scm_cons (evaluate_with_simple_closure (delayed_argument, scm_car (s),
  48                                                       pure, start, end),
  49                         SCM_EOL);
  50       if (scm_car (*tail) == SCM_UNSPECIFIED)
  51         return SCM_UNSPECIFIED;
  52       tail = SCM_CDRLOC (*tail);
  53     }
  54
  55   return new_args;
  56 }
  57
  58 SCM
  59 evaluate_with_simple_closure (SCM delayed_argument,
  60                               SCM expr,
  61                               bool pure,
  62                               int start,
  63                               int end)
  64 {
  65   if (is_simple_closure (expr))
  66     {
  67       SCM inside = simple_closure_expression (expr);
  68       SCM proc = is_unpure_pure_container (scm_car (inside))
  69                ? (pure ? scm_car (inside) : unpure_pure_container_unpure_part (scm_car (inside)))
  70                : scm_car (inside);
  71       SCM args = scm_cons (delayed_argument,
  72                            evaluate_args (delayed_argument, scm_cdr (inside),
  73                                           pure, start, end));
  74       if (scm_cdr (args) == SCM_UNSPECIFIED)
  75         return SCM_UNSPECIFIED;
  76       if (pure)
  77         return call_pure_function (proc, args, start, end);
  78       return scm_apply_0 (proc, args);
  79     }
  80   else if (!scm_is_pair (expr))
  81     return expr;
  82   else if (scm_car (expr) == ly_symbol2scm ("quote"))
  83     return scm_cadr (expr);
  84   else if (is_unpure_pure_container (scm_car (expr))
  85            || ly_is_procedure (scm_car (expr)))
  86     {
  87       SCM proc = is_unpure_pure_container (scm_car (expr))
  88                ? (pure ? scm_car (expr) : unpure_pure_container_unpure_part (scm_car (expr)))
  89                : scm_car (expr);
  90       SCM args = evaluate_args (delayed_argument, scm_cdr (expr), pure, start, end);
  91       if (args == SCM_UNSPECIFIED)
  92         return SCM_UNSPECIFIED;
  93       if (pure)
  94         return call_pure_function (proc, args, start, end);
  95       return scm_apply_0 (proc, args);
  96     }
  97   else
  98     // ugh. deviation from standard. Should print error?
  99     return evaluate_args (delayed_argument, scm_cdr (expr), pure, start, end);
 100
 101   assert (false);
 102   return SCM_EOL;
 103 }
 104
 105 LY_DEFINE (ly_simple_closure_p, "ly:simple-closure?",
 106            1, 0, 0, (SCM clos),
 107            "Is @var{clos} a simple closure?")
 108 {
 109   return scm_from_bool (is_simple_closure (clos));
 110 }
 111
 112 LY_DEFINE (ly_make_simple_closure, "ly:make-simple-closure",
 113            1, 0, 0, (SCM expr),
 114            "Make a simple closure.  @var{expr} should be form of"
 115            " @code{(@var{func} @var{a1} @var{a2} @dots{})}, and will be"
 116            " invoked as @code{(@var{func} @var{delayed-arg} @var{a1}"
 117            " @var{a2} @dots{})}.")
 118 {
 119   SCM z;
 120
 121   SCM_NEWSMOB (z, simple_closure_tag, expr);
 122   return z;
 123 }
 124
 125 LY_DEFINE (ly_eval_simple_closure, "ly:eval-simple-closure",
 126            2, 2, 0, (SCM delayed, SCM closure, SCM scm_start, SCM scm_end),
 127            "Evaluate a simple @var{closure} with the given @var{delayed}"
 128            " argument.  If @var{scm-start} and @var{scm-end} are defined,"
 129            " evaluate it purely with those start and end points.")
 130 {
 131   bool pure = (scm_is_number (scm_start) && scm_is_number (scm_end));
 132   int start = robust_scm2int (scm_start, 0);
 133   int end = robust_scm2int (scm_end, 0);
 134   SCM expr = simple_closure_expression (closure);
 135   return evaluate_with_simple_closure (delayed, expr, pure, start, end);
 136 }
 137
 138 int
 139 print_simple_closure (SCM s, SCM port, scm_print_state *)
 140 {
 141   scm_puts ("#<simple-closure ", port);
 142   scm_display (scm_cdr (s), port);
 143   scm_puts (" >", port);
 144   return 1;
 145 }
 146
 147 void init_simple_closure ()
 148 {
 149   simple_closure_tag = scm_make_smob_type ("simple-closure", 0);
 150   scm_set_smob_mark (simple_closure_tag, scm_markcdr);
 151   scm_set_smob_print (simple_closure_tag, print_simple_closure);
 152 };
 153
 154 ADD_SCM_INIT_FUNC (simple_closure, init_simple_closure);