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