lily/unpure-pure-container.cc

   1 /*
   2   This file is part of LilyPond, the GNU music typesetter.
   3
   4   Copyright (C) 2011--2012 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 #include "grob.hh"
  23
  24 static scm_t_bits unpure_pure_container_tag;
  25 static scm_t_bits unpure_pure_call_tag;
  26 // Used for rerouting a function of (grob start end) to one of
  27 // (grob)
  28
  29 bool
  30 is_unpure_pure_container (SCM s)
  31 {
  32   return (SCM_NIMP (s) && SCM_CELL_TYPE (s) == unpure_pure_container_tag);
  33 }
  34
  35 SCM
  36 unpure_pure_container_unpure_part (SCM smob)
  37 {
  38   LY_ASSERT_TYPE (is_unpure_pure_container, smob, 1);
  39   return SCM_SMOB_OBJECT (smob);
  40 }
  41
  42 SCM
  43 unpure_pure_container_pure_part (SCM smob)
  44 {
  45   LY_ASSERT_TYPE (is_unpure_pure_container, smob, 1);
  46   SCM res = SCM_SMOB_OBJECT_2 (smob);
  47
  48   if (!SCM_UNBNDP (res))
  49     return res;
  50
  51   SCM_NEWSMOB (res, unpure_pure_call_tag,
  52                SCM_UNPACK (unpure_pure_container_unpure_part (smob)));
  53   return res;
  54 }
  55
  56 LY_DEFINE (ly_unpure_pure_container_p, "ly:unpure-pure-container?",
  57            1, 0, 0, (SCM clos),
  58            "Is @var{clos} an unpure pure container?")
  59 {
  60   return scm_from_bool (is_unpure_pure_container (clos));
  61 }
  62
  63 LY_DEFINE (ly_make_unpure_pure_container, "ly:make-unpure-pure-container",
  64            1, 1, 0, (SCM unpure, SCM pure),
  65            "Make an unpure-pure container.  @var{unpure} should be an unpure"
  66            " expression, and @var{pure} should be a pure expression.  If @var{pure}"
  67            " is omitted, the value of @var{unpure} will be used twice,"
  68            " except that a callback is given two extra arguments"
  69            " that are ignored for the sake of pure calculations.")
  70 {
  71   SCM z;
  72
  73   if (SCM_UNBNDP (pure) && !ly_is_procedure (unpure))
  74     pure = unpure;
  75
  76   SCM_NEWSMOB2 (z, unpure_pure_container_tag, SCM_UNPACK (unpure), SCM_UNPACK (pure));
  77   return z;
  78 }
  79
  80 LY_DEFINE (ly_unpure_pure_container_unpure_part, "ly:unpure-pure-container-unpure-part",
  81            1, 0, 0, (SCM pc),
  82            "Return the unpure part of @var{pc}.")
  83 {
  84   LY_ASSERT_TYPE (is_unpure_pure_container, pc, 1);
  85   return unpure_pure_container_unpure_part (pc);
  86 }
  87
  88 LY_DEFINE (ly_unpure_pure_container_pure_part, "ly:unpure-pure-container-pure-part",
  89            1, 0, 0, (SCM pc),
  90            "Return the pure part of @var{pc}.")
  91 {
  92   LY_ASSERT_TYPE (is_unpure_pure_container, pc, 1);
  93   return unpure_pure_container_pure_part (pc);
  94 }
  95
  96 int
  97 print_unpure_pure_container (SCM s, SCM port, scm_print_state *)
  98 {
  99   scm_puts ("#<unpure-pure-container ", port);
 100   scm_display (unpure_pure_container_unpure_part (s), port);
 101   if (!SCM_UNBNDP (SCM_SMOB_OBJECT_2 (s)))
 102     {
 103       scm_puts (" ", port);
 104       scm_display (unpure_pure_container_pure_part (s), port);
 105     }
 106   scm_puts (" >", port);
 107   return 1;
 108 }
 109
 110 SCM
 111 pure_mark (SCM smob)
 112 {
 113   scm_gc_mark (SCM_SMOB_OBJECT (smob));
 114   return SCM_SMOB_OBJECT_2 (smob);
 115 }
 116
 117 // Function signature has two fixed arguments so that dropping two
 118 // will always work: if we have fewer to start with, it will trigger
 119 // wrong-number-of-args in a sensible location rather than making
 120 // drop-right barf.
 121
 122 SCM
 123 apply_unpure_pure (SCM clo, SCM arg1, SCM arg2, SCM rest)
 124 {
 125   return scm_apply_0 (SCM_SMOB_OBJECT (clo),
 126                       scm_call_2 (ly_lily_module_constant ("drop-right"),
 127                                   scm_cons2 (arg1, arg2, rest),
 128                                   scm_from_int (2)));
 129 }
 130
 131
 132 void init_unpure_pure_container ()
 133 {
 134   unpure_pure_container_tag = scm_make_smob_type ("unpure-pure-container", 0);
 135   scm_set_smob_mark (unpure_pure_container_tag, pure_mark);
 136   scm_set_smob_print (unpure_pure_container_tag, print_unpure_pure_container);
 137   unpure_pure_call_tag = scm_make_smob_type ("unpure-pure-call", 0);
 138   scm_set_smob_mark (unpure_pure_call_tag, scm_markcdr);
 139   scm_set_smob_apply (unpure_pure_call_tag,
 140                       (scm_t_subr) apply_unpure_pure, 2, 0, 1);
 141 };
 142
 143 ADD_SCM_INIT_FUNC (unpure_pure_container, init_unpure_pure_container);