lily/simple-closure.cc

   1 /*
   2   This file is part of LilyPond, the GNU music typesetter.
   3
   4   Copyright (C) 2005--2015 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 SCM
  26 evaluate_args (SCM delayed_argument, SCM args, bool pure, int start, int end)
  27 {
  28   SCM new_args = SCM_EOL;
  29   SCM *tail = &new_args;
  30   for (SCM s = args; scm_is_pair (s); s = scm_cdr (s))
  31     {
  32       *tail = scm_cons (evaluate_with_simple_closure (delayed_argument, scm_car (s),
  33                                                       pure, start, end),
  34                         SCM_EOL);
  35       if (scm_car (*tail) == SCM_UNSPECIFIED)
  36         return SCM_UNSPECIFIED;
  37       tail = SCM_CDRLOC (*tail);
  38     }
  39
  40   return new_args;
  41 }
  42
  43 SCM
  44 evaluate_with_simple_closure (SCM delayed_argument,
  45                               SCM expr,
  46                               bool pure,
  47                               int start,
  48                               int end)
  49 {
  50   if (Simple_closure *sc = Simple_closure::unsmob (expr))
  51     {
  52       SCM inside = sc->expression ();
  53       SCM proc = !pure && Unpure_pure_container::is_smob (scm_car (inside))
  54         ? Unpure_pure_container::unsmob (scm_car (inside))->unpure_part ()
  55         : scm_car (inside);
  56       SCM args = scm_cons (delayed_argument,
  57                            evaluate_args (delayed_argument, scm_cdr (inside),
  58                                           pure, start, end));
  59       if (scm_cdr (args) == SCM_UNSPECIFIED)
  60         return SCM_UNSPECIFIED;
  61       if (pure)
  62         return call_pure_function (proc, args, start, end);
  63       return scm_apply_0 (proc, args);
  64     }
  65   else if (!scm_is_pair (expr))
  66     return expr;
  67   else if (scm_car (expr) == ly_symbol2scm ("quote"))
  68     return scm_cadr (expr);
  69   else if (Unpure_pure_container::is_smob (scm_car (expr))
  70            || ly_is_procedure (scm_car (expr)))
  71     {
  72       SCM proc = !pure && Unpure_pure_container::is_smob (scm_car (expr))
  73         ? Unpure_pure_container::unsmob (scm_car (expr))->unpure_part ()
  74         : scm_car (expr);
  75       SCM args = evaluate_args (delayed_argument, scm_cdr (expr), pure, start, end);
  76       if (args == SCM_UNSPECIFIED)
  77         return SCM_UNSPECIFIED;
  78       if (pure)
  79         return call_pure_function (proc, args, start, end);
  80       return scm_apply_0 (proc, args);
  81     }
  82   else
  83     // ugh. deviation from standard. Should print error?
  84     return evaluate_args (delayed_argument, scm_cdr (expr), pure, start, end);
  85
  86   assert (false);
  87   return SCM_EOL;
  88 }
  89
  90 const char Simple_closure::type_p_name_[] = "ly:simple-closure?";
  91
  92 LY_DEFINE (ly_make_simple_closure, "ly:make-simple-closure",
  93            1, 0, 0, (SCM expr),
  94            "Make a simple closure.  @var{expr} should be form of"
  95            " @code{(@var{func} @var{a1} @var{a2} @dots{})}, and will be"
  96            " invoked as @code{(@var{func} @var{delayed-arg} @var{a1}"
  97            " @var{a2} @dots{})}.")
  98 {
  99   return Simple_closure::make_smob (expr);
 100 }
 101
 102 LY_DEFINE (ly_eval_simple_closure, "ly:eval-simple-closure",
 103            2, 2, 0, (SCM delayed, SCM closure, SCM scm_start, SCM scm_end),
 104            "Evaluate a simple @var{closure} with the given @var{delayed}"
 105            " argument.  If @var{scm-start} and @var{scm-end} are defined,"
 106            " evaluate it purely with those start and end points.")
 107 {
 108   LY_ASSERT_SMOB (Simple_closure, closure, 2);
 109   bool pure = (scm_is_number (scm_start) && scm_is_number (scm_end));
 110   int start = robust_scm2int (scm_start, 0);
 111   int end = robust_scm2int (scm_end, 0);
 112   SCM expr = Simple_closure::unsmob (closure)->expression ();
 113   return evaluate_with_simple_closure (delayed, expr, pure, start, end);
 114 }
 115
 116 int
 117 Simple_closure::print_smob (SCM port, scm_print_state *)
 118 {
 119   scm_puts ("#<simple-closure ", port);
 120   scm_display (expression (), port);
 121   scm_puts (" >", port);
 122   return 1;
 123 }