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