lily/general-scheme.cc

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