lily/general-scheme.cc

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