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 <cstring>  /* memset */
  14 using namespace std;
  15
  16 #include "international.hh"
  17 #include "libc-extension.hh"
  18 #include "lily-guile.hh"
  19 #include "misc.hh"
  20 #include "warn.hh"
  21 #include "version.hh"
  22 #include "dimensions.hh"
  23 #include "main.hh"
  24 #include "file-path.hh"
  25 #include "relocate.hh"
  26 #include "file-name.hh"
  27
  28 LY_DEFINE (ly_find_file, "ly:find-file",
  29            1, 0, 0, (SCM name),
  30            "Return the absolute file name of @var{name}, "
  31            "or @code{#f} if not found.")
  32 {
  33   SCM_ASSERT_TYPE (scm_is_string (name), name, SCM_ARG1, __FUNCTION__, "string");
  34
  35   string nm = ly_scm2string (name);
  36   string file_name = global_path.find (nm);
  37   if (file_name.empty ())
  38     return SCM_BOOL_F;
  39
  40   return ly_string2scm (file_name);
  41 }
  42
  43 /*
  44   Ugh. Gulped file is copied twice. (maybe thrice if you count stdio
  45   buffering.)
  46 */
  47 LY_DEFINE (ly_gulp_file, "ly:gulp-file",
  48            1, 1, 0, (SCM name, SCM size),
  49            "Read the file @var{name}, and return its contents in a string.  "
  50            "The file is looked up using the search path. ")
  51 {
  52   SCM_ASSERT_TYPE (scm_is_string (name), name, SCM_ARG1, __FUNCTION__, "string");
  53   int sz = INT_MAX;
  54   if (size != SCM_UNDEFINED)
  55     {
  56       SCM_ASSERT_TYPE (scm_is_number (size), size, SCM_ARG2, __FUNCTION__, "number");
  57       sz = scm_to_int (size);
  58     }
  59
  60   string contents = gulp_file_to_string (ly_scm2string (name), true, sz);
  61   return scm_from_locale_stringn (contents.c_str (), contents.length ());
  62 }
  63
  64 LY_DEFINE (ly_error, "ly:error",
  65            1, 0, 1, (SCM str, SCM rest),
  66            "Scheme callable function to issue the error @code{msg}. "
  67            "The error is formatted with @code{format} and @code{rest}.")
  68 {
  69   SCM_ASSERT_TYPE (scm_is_string (str), str, SCM_ARG1, __FUNCTION__, "string");
  70   str = scm_simple_format (SCM_BOOL_F, str, rest);
  71   error (ly_scm2string (str));
  72   return SCM_UNSPECIFIED;
  73 }
  74
  75 LY_DEFINE (ly_message, "ly:message",
  76            1, 0, 1, (SCM str, SCM rest),
  77            "Scheme callable function to issue the message @code{msg}. "
  78            "The message is formatted with @code{format} and @code{rest}.")
  79 {
  80   SCM_ASSERT_TYPE (scm_is_string (str), str, SCM_ARG1, __FUNCTION__, "string");
  81   str = scm_simple_format (SCM_BOOL_F, str, rest);
  82   message (ly_scm2string (str));
  83   return SCM_UNSPECIFIED;
  84 }
  85
  86 LY_DEFINE (ly_progress, "ly:progress",
  87            1, 0, 1, (SCM str, SCM rest),
  88            "Scheme callable function to print progress @code{str}. "
  89            "The message is formatted with @code{format} and @code{rest}.")
  90 {
  91   SCM_ASSERT_TYPE (scm_is_string (str), str, SCM_ARG1, __FUNCTION__, "string");
  92   str = scm_simple_format (SCM_BOOL_F, str, rest);
  93   progress_indication (ly_scm2string (str));
  94   return SCM_UNSPECIFIED;
  95 }
  96
  97 LY_DEFINE (ly_programming_error, "ly:programming-error",
  98            1, 0, 1, (SCM str, SCM rest),
  99            "Scheme callable function to issue the warning @code{msg}. "
 100            "The message is formatted with @code{format} and @code{rest}.")
 101 {
 102   SCM_ASSERT_TYPE (scm_is_string (str), str, SCM_ARG1, __FUNCTION__, "string");
 103   str = scm_simple_format (SCM_BOOL_F, str, rest);
 104   programming_error (ly_scm2string (str));
 105   return SCM_UNSPECIFIED;
 106 }
 107
 108 LY_DEFINE (ly_warning, "ly:warning",
 109            1, 0, 1, (SCM str, SCM rest),
 110            "Scheme callable function to issue the warning @code{str}. "
 111            "The message is formatted with @code{format} and @code{rest}.")
 112 {
 113   SCM_ASSERT_TYPE (scm_is_string (str), str, SCM_ARG1, __FUNCTION__, "string");
 114   str = scm_simple_format (SCM_BOOL_F, str, rest);
 115   warning (ly_scm2string (str));
 116   return SCM_UNSPECIFIED;
 117 }
 118
 119 LY_DEFINE (ly_dir_p, "ly:dir?",
 120            1, 0, 0, (SCM s),
 121            "type predicate. A direction is @code{-1}, @code{0} or "
 122            "@code{1}, where @code{-1} represents "
 123            "left or down and @code{1} represents right or up.")
 124 {
 125   if (scm_is_number (s))
 126     {
 127       int i = scm_to_int (s);
 128       return (i >= -1 && i <= 1) ? SCM_BOOL_T : SCM_BOOL_F;
 129     }
 130   return SCM_BOOL_F;
 131 }
 132
 133 LY_DEFINE (ly_assoc_get, "ly:assoc-get",
 134            2, 1, 0,
 135            (SCM key, SCM alist, SCM default_value),
 136            "Return value if KEY in ALIST, else DEFAULT-VALUE "
 137            "(or #f if not specified).")
 138 {
 139   SCM handle = scm_assoc (key, alist);
 140   if (scm_is_pair (handle))
 141     return scm_cdr (handle);
 142
 143   if (default_value == SCM_UNDEFINED)
 144     default_value = SCM_BOOL_F;
 145
 146   return default_value;
 147 }
 148
 149 LY_DEFINE (ly_string_substitute, "ly:string-substitute",
 150            3, 0, 0, (SCM a, SCM b, SCM s),
 151            "Replace @var{a} by @var{b} in @var{s}.")
 152 {
 153   SCM_ASSERT_TYPE (scm_is_string (a), s, SCM_ARG1, __FUNCTION__, "string");
 154   SCM_ASSERT_TYPE (scm_is_string (b), s, SCM_ARG2, __FUNCTION__, "string");
 155   SCM_ASSERT_TYPE (scm_is_string (s), s, SCM_ARG3, __FUNCTION__, "string");
 156
 157   string ss = ly_scm2string (s);
 158   replace_all (ss, string (scm_i_string_chars (a)),
 159                    string (scm_i_string_chars (b)));
 160   return ly_string2scm (ss);
 161 }
 162
 163 LY_DEFINE (ly_number2string, "ly:number->string",
 164            1, 0, 0, (SCM s),
 165            "Convert @var{num} to a string without generating many decimals.")
 166 {
 167   SCM_ASSERT_TYPE (scm_is_number (s), s, SCM_ARG1, __FUNCTION__, "number");
 168
 169   char str[400];                        // ugh.
 170
 171   if (scm_exact_p (s) == SCM_BOOL_F)
 172     {
 173       Real r (scm_to_double (s));
 174         if (isinf (r) || isnan (r))
 175           {
 176             programming_error (_ ("infinity or NaN encountered while converting Real number"));
 177             programming_error (_ ("setting to zero"));
 178
 179             r = 0.0;
 180           }
 181
 182       snprintf (str, sizeof (str), "%.4f", r);
 183     }
 184   else
 185     snprintf (str, sizeof (str), "%d", int (scm_to_int (s)));
 186
 187   return scm_from_locale_string (str);
 188 }
 189
 190 LY_DEFINE (ly_version, "ly:version", 0, 0, 0, (),
 191            "Return the current lilypond version as a list, e.g. @code{(1 3 127 uu1)}. ")
 192 {
 193   char const *vs = "\'(" MAJOR_VERSION " " MINOR_VERSION " " PATCH_LEVEL " " MY_PATCH_LEVEL ")";
 194
 195   return scm_c_eval_string ((char *)vs);
 196 }
 197
 198 LY_DEFINE (ly_unit, "ly:unit", 0, 0, 0, (),
 199            "Return the unit used for lengths as a string.")
 200 {
 201   return scm_from_locale_string (INTERNAL_UNIT);
 202 }
 203
 204 LY_DEFINE (ly_dimension_p, "ly:dimension?", 1, 0, 0, (SCM d),
 205            "Return @var{d} is a number. Used to distinguish length "
 206            "variables from normal numbers.")
 207 {
 208   return scm_number_p (d);
 209 }
 210
 211 /*
 212   Debugging mem leaks:
 213 */
 214 LY_DEFINE (ly_protects, "ly:protects",
 215            0, 0, 0, (),
 216            "Return hash of protected objects.")
 217 {
 218   return scm_protects;
 219 }
 220
 221 LY_DEFINE (ly_gettext, "ly:gettext",
 222            1, 0, 0, (SCM string),
 223            "Gettext wrapper.")
 224 {
 225   SCM_ASSERT_TYPE (scm_is_string (string), string, SCM_ARG1,
 226                    __FUNCTION__, "string");
 227   return ly_string2scm (_ (scm_i_string_chars (string)));
 228 }
 229
 230 LY_DEFINE (ly_output_backend, "ly:output-backend",
 231            0, 0, 0, (),
 232            "Return name of output backend.")
 233 {
 234   return ly_string2scm (output_backend_global);
 235 }
 236
 237 LY_DEFINE (ly_output_formats, "ly:output-formats",
 238            0, 0, 0, (),
 239            "Formats passed to --format as a list of strings, "
 240            "used for the output.")
 241 {
 242   vector<string> output_formats = string_split (output_format_global, ',');
 243
 244   SCM lst = SCM_EOL;
 245   int output_formats_count = output_formats.size ();
 246   for (int i = 0; i < output_formats_count; i++)
 247     lst = scm_cons (ly_string2scm (output_formats[i]), lst);
 248
 249   return lst;
 250 }
 251
 252 LY_DEFINE (ly_wchar_to_utf_8, "ly:wide-char->utf-8",
 253            1, 0, 0, (SCM wc),
 254            "Encode the Unicode codepoint @var{wc}, an integer, as UTF-8")
 255 {
 256   char buf[5];
 257
 258   SCM_ASSERT_TYPE (scm_is_integer (wc), wc, SCM_ARG1, __FUNCTION__, "integer");
 259   unsigned wide_char = (unsigned) scm_to_int (wc);
 260   char *p = buf;
 261
 262   if (wide_char < 0x0080)
 263     *p++ = (char)wide_char;
 264   else if (wide_char < 0x0800)
 265     {
 266       *p++ = (char) (((wide_char >> 6)) | 0xC0);
 267       *p++ = (char) (((wide_char) & 0x3F) | 0x80);
 268     }
 269   else if (wide_char < 0x10000)
 270     {
 271       *p++ = (char) (((wide_char >> 12)) | 0xE0);
 272       *p++ = (char) (((wide_char >> 6) & 0x3F) | 0x80);
 273       *p++ = (char) (((wide_char) & 0x3F) | 0x80);
 274     }
 275   else
 276     {
 277       *p++ = (char) (((wide_char >> 18)) | 0xF0);
 278       *p++ = (char) (((wide_char >> 12) & 0x3F) | 0x80);
 279       *p++ = (char) (((wide_char >> 6) & 0x3F) | 0x80);
 280       *p++ = (char) (((wide_char) & 0x3F) | 0x80);
 281     }
 282   *p = 0;
 283
 284   return scm_from_locale_string (buf);
 285 }
 286
 287 LY_DEFINE (ly_effective_prefix, "ly:effective-prefix",
 288            0, 0, 0, (),
 289            "Return effective prefix.")
 290 {
 291   return ly_string2scm (prefix_directory);
 292 }
 293
 294 LY_DEFINE (ly_chain_assoc_get, "ly:chain-assoc-get",
 295            2, 1, 0, (SCM key, SCM achain, SCM dfault),
 296            "Return value for @var{key} from a list of alists @var{achain}.  "
 297            "If no if no entry is found, return DFAULT, "
 298            "or #f if no DFAULT not specified.")
 299 {
 300   if (scm_is_pair (achain))
 301     {
 302       SCM handle = scm_assoc (key, scm_car (achain));
 303       if (scm_is_pair (handle))
 304         return scm_cdr (handle);
 305       else
 306         return ly_chain_assoc_get (key, scm_cdr (achain), dfault);
 307     }
 308   return dfault == SCM_UNDEFINED ? SCM_BOOL_F : dfault;
 309 }
 310
 311
 312 LY_DEFINE (ly_stderr_redirect, "ly:stderr-redirect",
 313            1, 1, 0, (SCM file_name, SCM mode),
 314            "Redirect stderr to FILE-NAME, opened with MODE.")
 315 {
 316   SCM_ASSERT_TYPE (scm_is_string (file_name), file_name, SCM_ARG1,
 317                    __FUNCTION__, "file_name");
 318
 319   string m = "w";
 320   if (mode != SCM_UNDEFINED && scm_string_p (mode))
 321     m = ly_scm2string (mode);
 322   /* dup2 and (fileno (current-error-port)) do not work with mingw'c
 323      gcc -mwindows.  */
 324   fflush (stderr);
 325   freopen (ly_scm2string (file_name).c_str (), m.c_str (), stderr);
 326   return SCM_UNSPECIFIED;
 327 }
 328
 329 static SCM
 330 accumulate_symbol (void *closure, SCM key, SCM val, SCM result)
 331 {
 332   (void) closure;
 333   (void) val;
 334   return scm_cons (key, result);
 335 }
 336
 337 LY_DEFINE(ly_hash_table_keys, "ly:hash-table-keys",
 338           1,0,0, (SCM tab),
 339           "return a list of keys in @var{tab}")
 340 {
 341   return scm_internal_hash_fold ((Hash_closure_function) & accumulate_symbol,
 342                                  NULL, SCM_EOL, tab);
 343 }
 344
 345 LY_DEFINE (ly_camel_case_to_lisp_identifier, "ly:camel-case->lisp-identifier",
 346            1, 0, 0, (SCM name_sym),
 347            "Convert FooBar_Bla to foo-bar-bla style symbol.")
 348 {
 349   SCM_ASSERT_TYPE(scm_is_symbol (name_sym), name_sym,
 350                   SCM_ARG1, __FUNCTION__, "symbol");
 351
 352   /*
 353     TODO: should use strings instead?
 354   */
 355
 356   const string in = ly_symbol2string (name_sym);
 357   string result = camel_case_to_lisp_identifier (in);
 358
 359   return ly_symbol2scm (result.c_str ());
 360 }
 361
 362 LY_DEFINE (ly_expand_environment, "ly:expand-environment",
 363            1, 0, 0, (SCM str),
 364            "Expand $VAR and $@{VAR@} in @var{str}.")
 365 {
 366   SCM_ASSERT_TYPE(scm_is_string (str), str,
 367                   SCM_ARG1, __FUNCTION__, "string");
 368
 369   return ly_string2scm (expand_environment_variables (ly_scm2string (str)));
 370 }
 371
 372
 373 LY_DEFINE (ly_truncate_list_x, "ly:truncate-list!",
 374            2, 0, 0, (SCM lst, SCM i),
 375            "Take at most the first @var{i} of list @var{lst}")
 376 {
 377   SCM_ASSERT_TYPE(scm_is_integer (i), i,
 378                   SCM_ARG1, __FUNCTION__, "integer");
 379
 380   int k = scm_to_int (i);
 381   if (k == 0)
 382     lst = SCM_EOL;
 383   else
 384     {
 385       SCM s = lst;
 386       k--;
 387       for (; scm_is_pair (s) && k--; s = scm_cdr (s))
 388         ;
 389
 390       if (scm_is_pair (s))
 391         scm_set_cdr_x (s, SCM_EOL);
 392     }
 393   return lst;
 394 }
 395