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