lily/music-function.cc

   1 /*
   2   This file is part of LilyPond, the GNU music typesetter.
   3
   4   Copyright (C) 2004--2015 Han-Wen Nienhuys <hanwen@xs4all.nl>
   5
   6   LilyPond is free software: you can redistribute it and/or modify
   7   it under the terms of the GNU General Public License as published by
   8   the Free Software Foundation, either version 3 of the License, or
   9   (at your option) any later version.
  10
  11   LilyPond is distributed in the hope that it will be useful,
  12   but WITHOUT ANY WARRANTY; without even the implied warranty of
  13   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14   GNU General Public License for more details.
  15
  16   You should have received a copy of the GNU General Public License
  17   along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.
  18 */
  19
  20 #include "music-function.hh"
  21 #include "lily-parser.hh"
  22 #include "input.hh"
  23 #include "music.hh"
  24 #include "fluid.hh"
  25
  26 const char Music_function::type_p_name_[] = "ly:music-function?";
  27
  28 /* Print a textual represenation of the smob to a given port.  */
  29 int
  30 Music_function::print_smob (SCM port, scm_print_state *)
  31 {
  32   scm_puts ("#<Music function ", port);
  33   scm_write (get_function (), port);
  34   scm_puts (">", port);
  35
  36   /* Non-zero means success.  */
  37   return 1;
  38 }
  39
  40 // Used for attaching location information to music expressions in
  41 // default arguments and return values.  Music expressions taken from
  42 // the call signature need to be cloned since they are not suitable
  43 // for multiple use.
  44
  45 static SCM
  46 with_loc (SCM arg, Fluid &loc, bool clone = true)
  47 {
  48   if (Music *m = unsmob<Music> (arg))
  49     {
  50       if (clone)
  51         {
  52           m = m->clone ();
  53           arg = m->unprotect ();
  54         }
  55       if (Input *in = unsmob<Input> (loc))
  56         m->set_spot (*in);
  57     }
  58   return arg;
  59 }
  60
  61 // A music function call implies walking through the call signature
  62 // and matching the actual argument list to the signature.  This
  63 // process is not 1:1 due to the possible presence of optional
  64 // arguments which are handled quite differently from how GUILE/Scheme
  65 // usually deal with optional arguments.
  66 //
  67 // The argument matching here intentionally closely tracks the
  68 // semantics of calls via the LilyPond parser as described in
  69 // <URL:lilypond.org/doc/Documentation/extending/scheme-function-usage>:
  70 // if an optional argument predicate does not match the next argument
  71 // from the actual argument list, the default given in the call
  72 // signature is used instead and all following optional arguments are
  73 // unconditionally substituted in a similar manner.
  74 //
  75 // This skipping of optional arguments can be explicitly initiated by
  76 // using \default in LilyPond.  The respective value to use for a call
  77 // via Scheme is *unspecified*.
  78
  79 SCM
  80 Music_function::call (SCM rest)
  81 {
  82   Fluid location (ly_lily_module_constant ("%location"));
  83
  84   // (car (ly:music-signature self_scm())) is the return type, skip it
  85   SCM signature = scm_cdr (get_signature ());
  86
  87   // In order to keep the loop structure and particularly the handling
  88   // of terminating conditions reasonably straightforward and avoid
  89   // scattering the code around, we don't use a separate loop when
  90   // skipping optional arguments.  Instead we use "skipping" to
  91   // indicate whether we are currently filling in optional arguments
  92   // from their defaults.
  93   bool skipping = false;
  94
  95   // The main loop just processes the signature in sequence, and the
  96   // resulting actual arguments are accumulated in reverse order in args
  97
  98   SCM args = SCM_EOL;
  99
 100   for (; scm_is_pair (signature); signature = scm_cdr (signature))
 101     {
 102       SCM pred = scm_car (signature);
 103
 104       if (scm_is_pair (pred))
 105         {
 106           // If the predicate is not a function but a pair, it
 107           // signifies an optional argument.  This is not quite the
 108           // form declared to define-music-function (which is always
 109           // a proper list) but a pair of predicate function and
 110           // default value.
 111
 112           if (!skipping)
 113             {
 114               if (!scm_is_pair (rest))
 115                 scm_wrong_num_args (self_scm ());
 116
 117               SCM arg = scm_car (rest);
 118               if (scm_is_true (scm_call_1 (scm_car (pred), arg)))
 119                 {
 120                   args = scm_cons (arg, args);
 121                   rest = scm_cdr (rest);
 122                   continue;
 123                 }
 124               skipping = true;
 125               // Remove at most one tentative "\default"
 126               if (scm_is_eq (SCM_UNSPECIFIED, arg))
 127                 rest = scm_cdr (rest);
 128             }
 129           args = scm_cons (with_loc (scm_cdr (pred), location), args);
 130           continue;
 131         }
 132
 133       // We have a mandatory argument here.
 134       skipping = false;
 135
 136       if (!scm_is_pair (rest))
 137         scm_wrong_num_args (self_scm ());
 138
 139       SCM arg = scm_car (rest);
 140       rest = scm_cdr (rest);
 141       args = scm_cons (arg, args);
 142
 143       if (scm_is_false (scm_call_1 (pred, arg)))
 144         {
 145           scm_call_4 (ly_lily_module_constant ("argument-error"),
 146                       location,
 147                       scm_from_int (scm_ilength (args)),
 148                       pred, arg);
 149           SCM val = scm_car (get_signature ());
 150           val = scm_is_pair (val) ? scm_cdr (val) : SCM_BOOL_F;
 151           return with_loc (val, location);
 152         }
 153     }
 154
 155   if (scm_is_pair (rest))
 156     scm_wrong_num_args (self_scm ());
 157
 158   SCM res = scm_apply_0 (get_function (), scm_reverse_x (args, SCM_EOL));
 159
 160   SCM pred = scm_car (get_signature ());
 161   // The return type predicate may have the form of a pair in which
 162   // the car is the actual predicate and the cdr is the surrogate
 163   // return value in the error case, to be extracted by
 164   // music-function-call-error.
 165   if (scm_is_pair (pred))
 166     pred = scm_car (pred);
 167
 168   if (scm_is_true (scm_call_1 (pred, res)))
 169     return with_loc (res, location, false);
 170
 171   return scm_call_2 (ly_lily_module_constant ("music-function-call-error"),
 172                      self_scm (), res);
 173 }