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 #include "lily-imports.hh"
  26
  27 const char Music_function::type_p_name_[] = "ly:music-function?";
  28
  29 /* Print a textual represenation of the smob to a given port.  */
  30 int
  31 Music_function::print_smob (SCM port, scm_print_state *) const
  32 {
  33   scm_puts ("#<Music function ", port);
  34   scm_write (get_function (), port);
  35   scm_puts (">", port);
  36
  37   /* Non-zero means success.  */
  38   return 1;
  39 }
  40
  41 // Used for attaching location information to music expressions in
  42 // default arguments and return values.  Music expressions taken from
  43 // the call signature need to be cloned since they are not suitable
  44 // for multiple use.
  45
  46 static SCM
  47 with_loc (SCM arg, Fluid &loc, bool clone = true)
  48 {
  49   if (Music *m = unsmob<Music> (arg))
  50     {
  51       if (clone)
  52         {
  53           m = m->clone ();
  54           arg = m->unprotect ();
  55         }
  56       if (Input *in = unsmob<Input> (loc))
  57         m->set_spot (*in);
  58     }
  59   return arg;
  60 }
  61
  62 // A music function call implies walking through the call signature
  63 // and matching the actual argument list to the signature.  This
  64 // process is not 1:1 due to the possible presence of optional
  65 // arguments which are handled quite differently from how GUILE/Scheme
  66 // usually deal with optional arguments.
  67 //
  68 // The argument matching here intentionally closely tracks the
  69 // semantics of calls via the LilyPond parser as described in
  70 // <URL:lilypond.org/doc/Documentation/extending/scheme-function-usage>:
  71 // if an optional argument predicate does not match the next argument
  72 // from the actual argument list, the default given in the call
  73 // signature is used instead and all following optional arguments are
  74 // unconditionally substituted in a similar manner.
  75 //
  76 // This skipping of optional arguments can be explicitly initiated by
  77 // using \default in LilyPond.  The respective value to use for a call
  78 // via Scheme is *unspecified*.
  79
  80 SCM
  81 Music_function::call (SCM rest)
  82 {
  83   Fluid location (Lily::f_location);
  84
  85   // (car (ly:music-signature self_scm())) is the return type, skip it
  86   SCM signature = scm_cdr (get_signature ());
  87
  88   // In order to keep the loop structure and particularly the handling
  89   // of terminating conditions reasonably straightforward and avoid
  90   // scattering the code around, we don't use a separate loop when
  91   // skipping optional arguments.  Instead we use "skipping" to
  92   // indicate whether we are currently filling in optional arguments
  93   // from their defaults.
  94   bool skipping = false;
  95
  96   // The main loop just processes the signature in sequence, and the
  97   // resulting actual arguments are accumulated in reverse order in args
  98
  99   SCM args = SCM_EOL;
 100
 101   for (; scm_is_pair (signature); signature = scm_cdr (signature))
 102     {
 103       SCM pred = scm_car (signature);
 104
 105       if (scm_is_pair (pred))
 106         {
 107           // If the predicate is not a function but a pair, it
 108           // signifies an optional argument.  This is not quite the
 109           // form declared to define-music-function (which is always
 110           // a proper list) but a pair of predicate function and
 111           // default value.
 112
 113           if (!skipping)
 114             {
 115               if (!scm_is_pair (rest))
 116                 scm_wrong_num_args (self_scm ());
 117
 118               SCM arg = scm_car (rest);
 119               if (scm_is_true (scm_call_1 (scm_car (pred), arg)))
 120                 {
 121                   args = scm_cons (arg, args);
 122                   rest = scm_cdr (rest);
 123                   continue;
 124                 }
 125               skipping = true;
 126               // Remove at most one tentative "\default"
 127               if (scm_is_eq (SCM_UNSPECIFIED, arg))
 128                 rest = scm_cdr (rest);
 129             }
 130           args = scm_cons (with_loc (scm_cdr (pred), location), args);
 131           continue;
 132         }
 133
 134       // We have a mandatory argument here.
 135       skipping = false;
 136
 137       if (!scm_is_pair (rest))
 138         scm_wrong_num_args (self_scm ());
 139
 140       SCM arg = scm_car (rest);
 141       rest = scm_cdr (rest);
 142       args = scm_cons (arg, args);
 143
 144       if (scm_is_false (scm_call_1 (pred, arg)))
 145         {
 146           Syntax::argument_error (scm_length (args),
 147                                   pred, arg);
 148           SCM val = scm_car (get_signature ());
 149           val = scm_is_pair (val) ? scm_cdr (val) : SCM_BOOL_F;
 150           return with_loc (val, location);
 151         }
 152     }
 153
 154   if (scm_is_pair (rest))
 155     scm_wrong_num_args (self_scm ());
 156
 157   SCM res = scm_apply_0 (get_function (), scm_reverse_x (args, SCM_EOL));
 158
 159   SCM pred = scm_car (get_signature ());
 160   // The return type predicate may have the form of a pair in which
 161   // the car is the actual predicate and the cdr is the surrogate
 162   // return value in the error case, to be extracted by
 163   // music-function-call-error.
 164   if (scm_is_pair (pred))
 165     pred = scm_car (pred);
 166
 167   if (scm_is_true (scm_call_1 (pred, res)))
 168     return with_loc (res, location, false);
 169
 170   return Syntax::music_function_call_error (self_scm (), res);
 171 }