lily/unpure-pure-container.cc

   1 /*
   2   This file is part of LilyPond, the GNU music typesetter.
   3
   4   Copyright (C) 2011--2015 Mike Solomon <mike@mikesolomon.org>
   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 "unpure-pure-container.hh"
  21
  22 // Reroutes a call to the contained function after dropping second and
  23 // third argument.  Used for applying an "unpure" function in a "pure"
  24 // context.
  25 class Unpure_pure_call : public Smob1<Unpure_pure_call>
  26 {
  27 public:
  28   // Smob procedures unfortunately can only take at most 3 SCM
  29   // arguments.  Otherwise we could use a "3, 0, 1" call signature and
  30   // not require an argument count check of our own.
  31   LY_DECLARE_SMOB_PROC (&Unpure_pure_call::call, 2, 0, 1)
  32   SCM call (SCM arg1, SCM, SCM rest)
  33   {
  34     if (!scm_is_pair (rest))
  35       scm_wrong_num_args (scm1 ());
  36     return scm_apply_1 (scm1 (), arg1, scm_cdr (rest));
  37   }
  38 };
  39
  40 SCM
  41 Unpure_pure_container::pure_part () const
  42 {
  43   return SCM_UNBNDP (scm2 ())
  44     ? Unpure_pure_call::make_smob (scm1 ())
  45     : scm2 ();
  46 }
  47
  48 const char * const Unpure_pure_container::type_p_name_ = "ly:unpure-pure-container?";
  49
  50 LY_DEFINE (ly_make_unpure_pure_container, "ly:make-unpure-pure-container",
  51            1, 1, 0, (SCM unpure, SCM pure),
  52            "Make an unpure-pure container.  @var{unpure} should be an unpure"
  53            " expression, and @var{pure} should be a pure expression.  If @var{pure}"
  54            " is omitted, the value of @var{unpure} will be used twice,"
  55            " except that a callback is given two extra arguments"
  56            " that are ignored for the sake of pure calculations.")
  57 {
  58   return Unpure_pure_container::make_smob (unpure, pure);
  59 }
  60
  61 LY_DEFINE (ly_unpure_pure_container_unpure_part, "ly:unpure-pure-container-unpure-part",
  62            1, 0, 0, (SCM pc),
  63            "Return the unpure part of @var{pc}.")
  64 {
  65   LY_ASSERT_SMOB (Unpure_pure_container, pc, 1);
  66   return unsmob<Unpure_pure_container> (pc)->unpure_part ();
  67 }
  68
  69 LY_DEFINE (ly_unpure_pure_container_pure_part, "ly:unpure-pure-container-pure-part",
  70            1, 0, 0, (SCM pc),
  71            "Return the pure part of @var{pc}.")
  72 {
  73   LY_ASSERT_SMOB (Unpure_pure_container, pc, 1);
  74   return unsmob<Unpure_pure_container> (pc)->pure_part ();
  75 }
  76
  77 int
  78 Unpure_pure_container::print_smob (SCM port, scm_print_state *) const
  79 {
  80   scm_puts ("#<unpure-pure-container ", port);
  81   scm_display (unpure_part (), port);
  82   if (!is_unchanging ())
  83     {
  84       scm_puts (" ", port);
  85       scm_display (pure_part (), port);
  86     }
  87   scm_puts (" >", port);
  88   return 1;
  89 }
  90
  91 LY_DEFINE (ly_pure_call, "ly:pure-call",
  92            4, 0, 1, (SCM data, SCM grob, SCM start, SCM end, SCM rest),
  93            "Convert property @var{data} (unpure-pure container or procedure)"
  94            " to value in a pure context defined by @var{grob},"
  95            " @var{start}, @var{end}, and possibly @var{rest} arguments.")
  96 {
  97   if (Unpure_pure_container *upc = unsmob<Unpure_pure_container> (data))
  98     {
  99       // Avoid gratuitous creation of an Unpure_pure_call
 100       if (upc->is_unchanging ())
 101         data = upc->unpure_part ();
 102       else
 103         {
 104           data = upc->pure_part ();
 105           if (ly_is_procedure (data))
 106             return scm_apply_3 (data, grob, start, end, rest);
 107           return data;
 108         }
 109     }
 110   if (ly_is_procedure (data))
 111     return scm_apply_1 (data, grob, rest);
 112   return data;
 113 }
 114
 115 LY_DEFINE (ly_unpure_call, "ly:unpure-call",
 116            2, 0, 1, (SCM data, SCM grob, SCM rest),
 117            "Convert property @var{data} (unpure-pure container or procedure)"
 118            " to value in an unpure context defined by @var{grob}"
 119            " and possibly @var{rest} arguments.")
 120 {
 121   if (Unpure_pure_container *upc = unsmob<Unpure_pure_container> (data))
 122     data = upc->unpure_part ();
 123   if (ly_is_procedure (data))
 124     return scm_apply_1 (data, grob, rest);
 125   return data;
 126 }