lily/general-scheme.cc

   1 /*
   2   This file is part of LilyPond, the GNU music typesetter.
   3
   4   Copyright (C) 1998--2009 Jan Nieuwenhuizen <janneke@gnu.org>
   5   Han-Wen Nienhuys <hanwen@xs4all.nl>
   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
  21 #include "config.hh"
  22
  23 #include <cstdio>
  24 #include <ctype.h>
  25 #include <cstring>  /* memset */
  26 using namespace std;
  27
  28 #include "dimensions.hh"
  29 #include "file-name.hh"
  30 #include "file-path.hh"
  31 #include "international.hh"
  32 #include "libc-extension.hh"
  33 #include "lily-guile.hh"
  34 #include "main.hh"
  35 #include "misc.hh"
  36 #include "program-option.hh"
  37 #include "relocate.hh"
  38 #include "string-convert.hh"
  39 #include "version.hh"
  40 #include "warn.hh"
  41
  42 LY_DEFINE (ly_start_environment, "ly:start-environment",
  43            0, 0, 0, (),
  44            "Return the environment (a list of strings) that was in"
  45            " effect at program start.")
  46 {
  47   SCM l = SCM_EOL;
  48   SCM *tail = &l;
  49
  50   for (vsize i = 0; i < start_environment_global.size (); i++)
  51     {
  52       *tail = scm_cons (ly_string2scm (start_environment_global[i]),
  53                         SCM_EOL);
  54       tail = SCM_CDRLOC(*tail);
  55     }
  56
  57   return l;
  58 }
  59
  60
  61 LY_DEFINE (ly_find_file, "ly:find-file",
  62            1, 0, 0, (SCM name),
  63            "Return the absolute file name of @var{name},"
  64            " or @code{#f} if not found.")
  65 {
  66   LY_ASSERT_TYPE (scm_is_string, name, 1);
  67
  68   string nm = ly_scm2string (name);
  69   string file_name = global_path.find (nm);
  70   if (file_name.empty ())
  71     return SCM_BOOL_F;
  72
  73   return ly_string2scm (file_name);
  74 }
  75
  76 /*
  77   Ugh. Gulped file is copied twice. (maybe thrice if you count stdio
  78   buffering.)
  79 */
  80 LY_DEFINE (ly_gulp_file, "ly:gulp-file",
  81            1, 1, 0, (SCM name, SCM size),
  82            "Read the file @var{name}, and return its contents in a string."
  83            "  The file is looked up using the search path.")
  84 {
  85   LY_ASSERT_TYPE (scm_is_string, name, 1);
  86   int sz = INT_MAX;
  87   if (size != SCM_UNDEFINED)
  88     {
  89       LY_ASSERT_TYPE (scm_is_number, size, 2);
  90       sz = scm_to_int (size);
  91     }
  92
  93   string contents = gulp_file_to_string (ly_scm2string (name), true, sz);
  94   return scm_from_locale_stringn (contents.c_str (), contents.length ());
  95 }
  96
  97 LY_DEFINE (ly_error, "ly:error",
  98            1, 0, 1, (SCM str, SCM rest),
  99            "A Scheme callable function to issue the error @var{str}."
 100            "  The error is formatted with @code{format} and @var{rest}.")
 101 {
 102   LY_ASSERT_TYPE (scm_is_string, str, 1);
 103   str = scm_simple_format (SCM_BOOL_F, str, rest);
 104   error (ly_scm2string (str));
 105   return SCM_UNSPECIFIED;
 106 }
 107
 108 LY_DEFINE (ly_message, "ly:message",
 109            1, 0, 1, (SCM str, SCM rest),
 110            "A Scheme callable function to issue the message @var{str}."
 111            "  The message is formatted with @code{format} and @var{rest}.")
 112 {
 113   LY_ASSERT_TYPE (scm_is_string, str, 1);
 114   str = scm_simple_format (SCM_BOOL_F, str, rest);
 115   message (ly_scm2string (str));
 116   return SCM_UNSPECIFIED;
 117 }
 118
 119 LY_DEFINE (ly_progress, "ly:progress",
 120            1, 0, 1, (SCM str, SCM rest),
 121            "A Scheme callable function to print progress @var{str}."
 122            "  The message is formatted with @code{format} and @var{rest}.")
 123 {
 124   LY_ASSERT_TYPE (scm_is_string, str, 1);
 125   str = scm_simple_format (SCM_BOOL_F, str, rest);
 126   progress_indication (ly_scm2string (str));
 127   return SCM_UNSPECIFIED;
 128 }
 129
 130 LY_DEFINE (ly_programming_error, "ly:programming-error",
 131            1, 0, 1, (SCM str, SCM rest),
 132            "A Scheme callable function to issue the internal warning"
 133            "  @var{str}.  The message is formatted with @code{format}"
 134            " and @var{rest}.")
 135 {
 136   LY_ASSERT_TYPE (scm_is_string, str, 1);
 137   str = scm_simple_format (SCM_BOOL_F, str, rest);
 138
 139   if (get_program_option ("warning-as-error"))
 140     error (ly_scm2string (str));
 141   else
 142     programming_error (ly_scm2string (str));
 143
 144   return SCM_UNSPECIFIED;
 145 }
 146
 147 LY_DEFINE (ly_warning, "ly:warning",
 148            1, 0, 1, (SCM str, SCM rest),
 149            "A Scheme callable function to issue the warning @code{str}."
 150            "  The message is formatted with @code{format} and @code{rest}.")
 151 {
 152   LY_ASSERT_TYPE (scm_is_string, str, 1);
 153   str = scm_simple_format (SCM_BOOL_F, str, rest);
 154
 155   if (get_program_option ("warning-as-error"))
 156     error (ly_scm2string (str));
 157   else
 158     warning (ly_scm2string (str));
 159
 160   return SCM_UNSPECIFIED;
 161 }
 162
 163 LY_DEFINE (ly_dir_p, "ly:dir?",
 164            1, 0, 0, (SCM s),
 165            "Is @var{s} a direction?  Valid directions are @code{-1},"
 166            " @code{0}, or@tie{}@code{1}, where @code{-1} represents"
 167            " left or down, @code{1}@tie{}represents right or up, and @code{0}"
 168            " represents a neutral direction.")
 169 {
 170   if (scm_is_number (s))
 171     {
 172       int i = scm_to_int (s);
 173       return (i >= -1 && i <= 1) ? SCM_BOOL_T : SCM_BOOL_F;
 174     }
 175   return SCM_BOOL_F;
 176 }
 177
 178 LY_DEFINE (ly_assoc_get, "ly:assoc-get",
 179            2, 2, 0,
 180            (SCM key, SCM alist, SCM default_value, SCM strict_checking),
 181            "Return value if @var{key} in @var{alist}, else @var{default-value}"
 182            " (or @code{#f} if not specified).  If @var{strict-checking} is set"
 183            " to @code{#t} and @var{key} is not in @var{alist}, a programming_error"
 184            " is output.")
 185 {
 186   LY_ASSERT_TYPE(ly_cheap_is_list, alist, 2);
 187
 188   SCM handle = scm_assoc (key, alist);
 189   if (scm_is_pair (handle))
 190     return scm_cdr (handle);
 191
 192   if (default_value == SCM_UNDEFINED)
 193     default_value = SCM_BOOL_F;
 194
 195   if (strict_checking == SCM_BOOL_T)
 196     {
 197       string key_string = ly_scm2string
 198                             (scm_object_to_string (key, SCM_UNDEFINED));
 199       string default_value_string = ly_scm2string
 200                                       (scm_object_to_string (default_value,
 201                                                              SCM_UNDEFINED));
 202       programming_error ("Cannot find key `" +
 203                          key_string +
 204                          "' in alist, setting to `" +
 205                          default_value_string + "'.");
 206     }
 207
 208   return default_value;
 209 }
 210
 211 LY_DEFINE (ly_string_substitute, "ly:string-substitute",
 212            3, 0, 0, (SCM a, SCM b, SCM s),
 213            "Replace string@tie{}@var{a} by string@tie{}@var{b} in"
 214            " string@tie{}@var{s}.")
 215 {
 216   LY_ASSERT_TYPE (scm_is_string, s, 1);
 217   LY_ASSERT_TYPE (scm_is_string, b, 2);
 218   LY_ASSERT_TYPE (scm_is_string, s, 3);
 219
 220   string ss = ly_scm2string (s);
 221   replace_all (&ss, ly_scm2string (a),
 222                ly_scm2string (b));
 223
 224   return ly_string2scm (ss);
 225 }
 226
 227 LY_DEFINE (ly_number_2_string, "ly:number->string",
 228            1, 0, 0, (SCM s),
 229            "Convert @var{num} to a string without generating many decimals.")
 230 {
 231   LY_ASSERT_TYPE (scm_is_number, s, 1);
 232
 233   char str[400];                        // ugh.
 234
 235   if (scm_exact_p (s) == SCM_BOOL_F)
 236     {
 237       Real r (scm_to_double (s));
 238         if (isinf (r) || isnan (r))
 239           {
 240             programming_error (_ ("infinity or NaN encountered while converting Real number"));
 241             programming_error (_ ("setting to zero"));
 242
 243             r = 0.0;
 244           }
 245
 246       snprintf (str, sizeof (str), "%.4f", r);
 247     }
 248   else
 249     snprintf (str, sizeof (str), "%d", int (scm_to_int (s)));
 250
 251   return scm_from_locale_string (str);
 252 }
 253
 254 LY_DEFINE (ly_version, "ly:version", 0, 0, 0, (),
 255            "Return the current lilypond version as a list, e.g.,"
 256            " @code{(1 3 127 uu1)}.")
 257 {
 258   char const *vs = "\'(" MAJOR_VERSION " " MINOR_VERSION " " PATCH_LEVEL " " MY_PATCH_LEVEL ")";
 259
 260   return scm_c_eval_string ((char *)vs);
 261 }
 262
 263 LY_DEFINE (ly_unit, "ly:unit", 0, 0, 0, (),
 264            "Return the unit used for lengths as a string.")
 265 {
 266   return scm_from_locale_string (INTERNAL_UNIT);
 267 }
 268
 269 LY_DEFINE (ly_dimension_p, "ly:dimension?", 1, 0, 0, (SCM d),
 270            "Return @var{d} as a number.  Used to distinguish length"
 271            " variables from normal numbers.")
 272 {
 273   return scm_number_p (d);
 274 }
 275
 276 /*
 277   Debugging mem leaks:
 278 */
 279 LY_DEFINE (ly_protects, "ly:protects",
 280            0, 0, 0, (),
 281            "Return hash of protected objects.")
 282 {
 283   return scm_protects;
 284 }
 285
 286 LY_DEFINE (ly_gettext, "ly:gettext",
 287            1, 0, 0, (SCM original),
 288            "A Scheme wrapper function for @code{gettext}.")
 289 {
 290   LY_ASSERT_TYPE (scm_is_string, original, 1);
 291   return ly_string2scm (_ (ly_scm2string (original).c_str ()));
 292 }
 293
 294 LY_DEFINE (ly_output_formats, "ly:output-formats",
 295            0, 0, 0, (),
 296            "Formats passed to @option{--format} as a list of strings,"
 297            " used for the output.")
 298 {
 299   vector<string> output_formats = string_split (output_format_global, ',');
 300
 301   SCM lst = SCM_EOL;
 302   int output_formats_count = output_formats.size ();
 303   for (int i = 0; i < output_formats_count; i++)
 304     lst = scm_cons (ly_string2scm (output_formats[i]), lst);
 305
 306   return lst;
 307 }
 308
 309 LY_DEFINE (ly_wide_char_2_utf_8, "ly:wide-char->utf-8",
 310            1, 0, 0, (SCM wc),
 311            "Encode the Unicode codepoint @var{wc}, an integer, as UTF-8.")
 312 {
 313   char buf[5];
 314
 315   LY_ASSERT_TYPE (scm_is_integer, wc, 1);
 316   unsigned wide_char = (unsigned) scm_to_int (wc);
 317   char *p = buf;
 318
 319   if (wide_char < 0x0080)
 320     *p++ = (char)wide_char;
 321   else if (wide_char < 0x0800)
 322     {
 323       *p++ = (char) (((wide_char >> 6)) | 0xC0);
 324       *p++ = (char) (((wide_char) & 0x3F) | 0x80);
 325     }
 326   else if (wide_char < 0x10000)
 327     {
 328       *p++ = (char) (((wide_char >> 12)) | 0xE0);
 329       *p++ = (char) (((wide_char >> 6) & 0x3F) | 0x80);
 330       *p++ = (char) (((wide_char) & 0x3F) | 0x80);
 331     }
 332   else
 333     {
 334       *p++ = (char) (((wide_char >> 18)) | 0xF0);
 335       *p++ = (char) (((wide_char >> 12) & 0x3F) | 0x80);
 336       *p++ = (char) (((wide_char >> 6) & 0x3F) | 0x80);
 337       *p++ = (char) (((wide_char) & 0x3F) | 0x80);
 338     }
 339   *p = 0;
 340
 341   return scm_from_locale_string (buf);
 342 }
 343
 344 LY_DEFINE (ly_effective_prefix, "ly:effective-prefix",
 345            0, 0, 0, (),
 346            "Return effective prefix.")
 347 {
 348   return ly_string2scm (lilypond_datadir);
 349 }
 350
 351 LY_DEFINE (ly_chain_assoc_get, "ly:chain-assoc-get",
 352            2, 2, 0, (SCM key, SCM achain, SCM default_value, SCM strict_checking),
 353            "Return value for @var{key} from a list of alists @var{achain}."
 354            "  If no entry is found, return @var{default-value} or @code{#f} if"
 355            " @var{default-value} is not specified.  With @var{strict-checking}"
 356            " set to @code{#t}, a programming_error is output in such cases.")
 357 {
 358   if (scm_is_pair (achain))
 359     {
 360       SCM handle = scm_assoc (key, scm_car (achain));
 361       if (scm_is_pair (handle))
 362         return scm_cdr (handle);
 363       else
 364         return ly_chain_assoc_get (key, scm_cdr (achain), default_value);
 365     }
 366
 367   if (strict_checking == SCM_BOOL_T)
 368     {
 369       string key_string = ly_scm2string
 370                             (scm_object_to_string (key, SCM_UNDEFINED));
 371       string default_value_string = ly_scm2string
 372                                       (scm_object_to_string (default_value,
 373                                                              SCM_UNDEFINED));
 374       programming_error ("Cannot find key `" +
 375                          key_string +
 376                          "' in achain, setting to `" +
 377                          default_value_string + "'.");
 378     }
 379
 380   return default_value == SCM_UNDEFINED ? SCM_BOOL_F : default_value;
 381 }
 382
 383
 384 LY_DEFINE (ly_stderr_redirect, "ly:stderr-redirect",
 385            1, 1, 0, (SCM file_name, SCM mode),
 386            "Redirect stderr to @var{file-name}, opened with @var{mode}.")
 387 {
 388   LY_ASSERT_TYPE (scm_is_string, file_name, 1);
 389
 390   string m = "w";
 391   if (mode != SCM_UNDEFINED && scm_string_p (mode))
 392     m = ly_scm2string (mode);
 393   /* dup2 and (fileno (current-error-port)) do not work with mingw'c
 394      gcc -mwindows.  */
 395   fflush (stderr);
 396   freopen (ly_scm2string (file_name).c_str (), m.c_str (), stderr);
 397   return SCM_UNSPECIFIED;
 398 }
 399
 400 static SCM
 401 accumulate_symbol (void * /* closure */,
 402                    SCM key,
 403                    SCM /* val */,
 404                    SCM result)
 405 {
 406   return scm_cons (key, result);
 407 }
 408
 409 LY_DEFINE (ly_hash_table_keys, "ly:hash-table-keys",
 410           1,0,0, (SCM tab),
 411           "Return a list of keys in @var{tab}.")
 412 {
 413   return scm_internal_hash_fold ((Hash_closure_function) & accumulate_symbol,
 414                                  NULL, SCM_EOL, tab);
 415 }
 416
 417 LY_DEFINE (ly_camel_case_2_lisp_identifier, "ly:camel-case->lisp-identifier",
 418            1, 0, 0, (SCM name_sym),
 419            "Convert @code{FooBar_Bla} to @code{foo-bar-bla} style symbol.")
 420 {
 421   LY_ASSERT_TYPE (ly_is_symbol, name_sym, 1);
 422
 423   /*
 424     TODO: should use strings instead?
 425   */
 426
 427   const string in = ly_symbol2string (name_sym);
 428   string result = camel_case_to_lisp_identifier (in);
 429
 430   return ly_symbol2scm (result.c_str ());
 431 }
 432
 433 LY_DEFINE (ly_expand_environment, "ly:expand-environment",
 434            1, 0, 0, (SCM str),
 435            "Expand @code{$VAR} and @code{$@{VAR@}} in @var{str}.")
 436 {
 437   LY_ASSERT_TYPE (scm_is_string, str, 1);
 438
 439   return ly_string2scm (expand_environment_variables (ly_scm2string (str)));
 440 }
 441
 442
 443 LY_DEFINE (ly_truncate_list_x, "ly:truncate-list!",
 444            2, 0, 0, (SCM lst, SCM i),
 445            "Take at most the first @var{i} of list @var{lst}.")
 446 {
 447   LY_ASSERT_TYPE (scm_is_integer, i, 1);
 448
 449   int k = scm_to_int (i);
 450   if (k == 0)
 451     lst = SCM_EOL;
 452   else
 453     {
 454       SCM s = lst;
 455       k--;
 456       for (; scm_is_pair (s) && k--; s = scm_cdr (s))
 457         ;
 458
 459       if (scm_is_pair (s))
 460         scm_set_cdr_x (s, SCM_EOL);
 461     }
 462   return lst;
 463 }
 464
 465 string
 466 format_single_argument (SCM arg, int precision, bool escape = false)
 467 {
 468   if (scm_is_integer (arg) && scm_exact_p (arg) == SCM_BOOL_T)
 469     return (String_convert::int_string (scm_to_int (arg)));
 470   else if (scm_is_number (arg))
 471     {
 472       Real val = scm_to_double (arg);
 473
 474       if (isnan (val) || isinf (val))
 475         {
 476           warning (_ ("Found infinity or nan in output. Substituting 0.0"));
 477           return ("0.0");
 478           if (strict_infinity_checking)
 479             abort ();
 480         }
 481       else
 482         return (String_convert::form_string ("%.*lf", precision, val));
 483     }
 484   else if (scm_is_string (arg))
 485     {
 486       string s = ly_scm2string (arg);
 487       if (escape)
 488         {
 489           // Escape backslashes and double quotes, wrap it in double quotes
 490           replace_all (&s, "\\", "\\\\");
 491           replace_all (&s, "\"", "\\\"");
 492           // don't replace percents, since the png backend uses %d as escape sequence
 493           // replace_all (&s, "%", "\\%");
 494           replace_all (&s, "$", "\\$");
 495           s = "\"" + s + "\"";
 496         }
 497       return s;
 498     }
 499   else if (scm_is_symbol (arg))
 500     return (ly_symbol2string (arg));
 501   else
 502     {
 503       ly_progress (scm_from_locale_string ("Unsupported SCM value for format: ~a"),
 504                    scm_list_1 (arg));
 505     }
 506
 507
 508   return "";
 509 }
 510
 511 LY_DEFINE (ly_format, "ly:format",
 512            1, 0, 1, (SCM str, SCM rest),
 513            "LilyPond specific format, supporting @code{~a} and @code{~[0-9]f}. "
 514            "Basic support for @code{~s} is also provided.")
 515 {
 516   LY_ASSERT_TYPE (scm_is_string, str, 1);
 517
 518   string format = ly_scm2string (str);
 519   vector<string> results;
 520
 521   vsize i = 0;
 522   while (i < format.size ())
 523     {
 524       vsize tilde = format.find ('~', i);
 525
 526       results.push_back (format.substr (i, (tilde-i)));
 527
 528       if (tilde == NPOS)
 529         break ;
 530
 531       tilde ++;
 532
 533       char spec = format.at (tilde ++);
 534       if (spec == '~')
 535         results.push_back ("~");
 536       else
 537         {
 538           if (!scm_is_pair (rest))
 539             {
 540               programming_error (string (__FUNCTION__)
 541                                  + ": not enough arguments for format.");
 542               return ly_string2scm ("");
 543             }
 544
 545           SCM arg = scm_car (rest);
 546           rest = scm_cdr (rest);
 547
 548           int precision = 8;
 549
 550           if (spec == '$')
 551             precision = 2;
 552           else if (isdigit (spec))
 553             {
 554               precision = spec - '0';
 555               spec = format.at (tilde ++);
 556             }
 557
 558           if (spec == 'a' || spec == 'A' || spec == 'f' || spec == '$')
 559             results.push_back (format_single_argument (arg, precision));
 560           else if (spec == 's' || spec == 'S')
 561             results.push_back (format_single_argument (arg, precision, true));
 562           else if (spec == 'l')
 563             {
 564               SCM s = arg;
 565               for (; scm_is_pair (s); s = scm_cdr (s))
 566                 {
 567                   results.push_back (format_single_argument (scm_car (s), precision));
 568                   if (scm_cdr (s) != SCM_EOL)
 569                     results.push_back (" ");
 570                 }
 571
 572               if (s != SCM_EOL)
 573                 results.push_back (format_single_argument (s, precision));
 574
 575             }
 576         }
 577
 578       i = tilde;
 579     }
 580
 581   if (scm_is_pair (rest))
 582     programming_error (string (__FUNCTION__)
 583                        + ": too many  arguments");
 584
 585   vsize len = 0;
 586   for (vsize i = 0; i < results.size (); i++)
 587     len += results[i].size ();
 588
 589   char *result = (char*) scm_malloc (len + 1);
 590   char *ptr = result;
 591   for (vsize i = 0; i < results.size (); i++)
 592     {
 593       strncpy (ptr, results[i].c_str (), results[i].size ());
 594       ptr += results[i].size ();
 595     }
 596   *ptr = '\0';
 597
 598   return scm_take_locale_stringn (result, len);
 599 }