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