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