+ 0, 0, 0, (),
+ "Return effective prefix.")
+{
+ return ly_string2scm (lilypond_datadir);
+}
+
+LY_DEFINE (ly_chain_assoc_get, "ly:chain-assoc-get",
+ 2, 2, 0, (SCM key, SCM achain, SCM default_value, SCM strict_checking),
+ "Return value for @var{key} from a list of alists @var{achain}."
+ " If no entry is found, return @var{default-value} or @code{#f} if"
+ " @var{default-value} is not specified. With @var{strict-checking}"
+ " set to @code{#t}, a programming_error is output in such cases.")
+{
+ if (scm_is_pair (achain))
+ {
+ SCM handle = scm_assoc (key, scm_car (achain));
+ if (scm_is_pair (handle))
+ return scm_cdr (handle);
+ else
+ return ly_chain_assoc_get (key, scm_cdr (achain), default_value);
+ }
+
+ if (strict_checking == SCM_BOOL_T)
+ {
+ string key_string = ly_scm2string
+ (scm_object_to_string (key, SCM_UNDEFINED));
+ string default_value_string = ly_scm2string
+ (scm_object_to_string (default_value,
+ SCM_UNDEFINED));
+ programming_error ("Cannot find key `"
+ + key_string
+ + "' in achain, setting to `"
+ + default_value_string + "'.");
+ }
+
+ return default_value == SCM_UNDEFINED ? SCM_BOOL_F : default_value;
+}
+
+LY_DEFINE (ly_stderr_redirect, "ly:stderr-redirect",
+ 1, 1, 0, (SCM file_name, SCM mode),
+ "Redirect stderr to @var{file-name}, opened with @var{mode}.")
+{
+ LY_ASSERT_TYPE (scm_is_string, file_name, 1);
+
+ string m = "w";
+ string f = ly_scm2string (file_name);
+ FILE *stderrfile;
+ if (scm_is_string (mode))
+ m = ly_scm2string (mode);
+ /* dup2 and (fileno (current-error-port)) do not work with mingw'c
+ gcc -mwindows. */
+ fflush (stderr);
+ stderrfile = freopen (f.c_str (), m.c_str (), stderr);
+ if (!stderrfile)
+ error (_f ("failed redirecting stderr to `%s'", f.c_str ()));
+ return SCM_UNSPECIFIED;
+}
+
+static SCM
+accumulate_symbol (void * /* closure */,
+ SCM key,
+ SCM /* val */,
+ SCM result)
+{
+ return scm_cons (key, result);
+}
+
+LY_DEFINE (ly_hash_table_keys, "ly:hash-table-keys",
+ 1, 0, 0, (SCM tab),
+ "Return a list of keys in @var{tab}.")
+{
+ return scm_internal_hash_fold ((scm_t_hash_fold_fn) &accumulate_symbol,
+ NULL, SCM_EOL, tab);
+}
+
+LY_DEFINE (ly_camel_case_2_lisp_identifier, "ly:camel-case->lisp-identifier",
+ 1, 0, 0, (SCM name_sym),
+ "Convert @code{FooBar_Bla} to @code{foo-bar-bla} style symbol.")
+{
+ LY_ASSERT_TYPE (ly_is_symbol, name_sym, 1);
+
+ /*
+ TODO: should use strings instead?
+ */
+
+ const string in = ly_symbol2string (name_sym);
+ string result = camel_case_to_lisp_identifier (in);
+
+ return ly_symbol2scm (result.c_str ());
+}
+
+LY_DEFINE (ly_expand_environment, "ly:expand-environment",
+ 1, 0, 0, (SCM str),
+ "Expand @code{$VAR} and @code{$@{VAR@}} in @var{str}.")
+{
+ LY_ASSERT_TYPE (scm_is_string, str, 1);
+
+ return ly_string2scm (expand_environment_variables (ly_scm2string (str)));
+}
+
+LY_DEFINE (ly_truncate_list_x, "ly:truncate-list!",
+ 2, 0, 0, (SCM lst, SCM i),
+ "Take at most the first @var{i} of list @var{lst}.")
+{
+ LY_ASSERT_TYPE (scm_is_integer, i, 1);
+
+ int k = scm_to_int (i);
+ if (k == 0)
+ lst = SCM_EOL;
+ else
+ {
+ SCM s = lst;
+ k--;
+ for (; scm_is_pair (s) && k--; s = scm_cdr (s))
+ ;
+
+ if (scm_is_pair (s))
+ scm_set_cdr_x (s, SCM_EOL);
+ }
+ return lst;
+}
+
+string
+format_single_argument (SCM arg, int precision, bool escape = false)
+{
+ if (scm_is_integer (arg) && scm_exact_p (arg) == SCM_BOOL_T)
+ return (String_convert::int_string (scm_to_int (arg)));
+ else if (scm_is_number (arg))
+ {
+ Real val = scm_to_double (arg);
+
+ if (isnan (val) || isinf (val))
+ {
+ warning (_ ("Found infinity or nan in output. Substituting 0.0"));
+ return ("0.0");
+ if (strict_infinity_checking)
+ abort ();
+ }
+ else
+ return (String_convert::form_string ("%.*lf", precision, val));
+ }
+ else if (scm_is_string (arg))
+ {
+ string s = ly_scm2string (arg);
+ if (escape)
+ {
+ // Escape backslashes and double quotes, wrap it in double quotes
+ replace_all (&s, "\\", "\\\\");
+ replace_all (&s, "\"", "\\\"");
+ // don't replace percents, since the png backend uses %d as escape sequence
+ // replace_all (&s, "%", "\\%");
+ replace_all (&s, "$", "\\$");
+ s = "\"" + s + "\"";
+ }
+ return s;
+ }
+ else if (scm_is_symbol (arg))
+ return (ly_symbol2string (arg));
+ else
+ {
+ ly_progress (scm_from_locale_string ("\nUnsupported SCM value for format: ~a"),
+ scm_list_1 (arg));
+ }
+
+ return "";
+}
+
+LY_DEFINE (ly_format, "ly:format",
+ 1, 0, 1, (SCM str, SCM rest),
+ "LilyPond specific format, supporting @code{~a} and @code{~[0-9]f}."
+ " Basic support for @code{~s} is also provided.")
+{
+ LY_ASSERT_TYPE (scm_is_string, str, 1);
+
+ string format = ly_scm2string (str);
+ vector<string> results;
+
+ vsize i = 0;
+ while (i < format.size ())
+ {
+ vsize tilde = format.find ('~', i);
+
+ results.push_back (format.substr (i, (tilde - i)));
+
+ if (tilde == NPOS)
+ break;
+
+ tilde++;
+
+ char spec = format.at (tilde++);
+ if (spec == '~')
+ results.push_back ("~");
+ else
+ {
+ if (!scm_is_pair (rest))
+ {
+ programming_error (string (__FUNCTION__)
+ + ": not enough arguments for format.");
+ return ly_string2scm ("");
+ }
+
+ SCM arg = scm_car (rest);
+ rest = scm_cdr (rest);
+
+ int precision = 8;
+
+ if (spec == '$')
+ precision = 2;
+ else if (isdigit (spec))
+ {
+ precision = spec - '0';
+ spec = format.at (tilde++);
+ }
+
+ if (spec == 'a' || spec == 'A' || spec == 'f' || spec == '$')
+ results.push_back (format_single_argument (arg, precision));
+ else if (spec == 's' || spec == 'S')
+ results.push_back (format_single_argument (arg, precision, true));
+ else if (spec == 'l')
+ {
+ SCM s = arg;
+ for (; scm_is_pair (s); s = scm_cdr (s))
+ {
+ results.push_back (format_single_argument (scm_car (s), precision));
+ if (scm_cdr (s) != SCM_EOL)
+ results.push_back (" ");
+ }
+
+ if (s != SCM_EOL)
+ results.push_back (format_single_argument (s, precision));
+
+ }
+ }
+
+ i = tilde;
+ }
+
+ if (scm_is_pair (rest))
+ programming_error (string (__FUNCTION__)
+ + ": too many arguments");
+
+ vsize len = 0;
+ for (vsize i = 0; i < results.size (); i++)
+ len += results[i].size ();
+
+ char *result = (char *) scm_malloc (len + 1);
+ char *ptr = result;
+ for (vsize i = 0; i < results.size (); i++)
+ {
+ strncpy (ptr, results[i].c_str (), results[i].size ());
+ ptr += results[i].size ();
+ }
+ *ptr = '\0';
+
+ return scm_take_locale_stringn (result, len);
+}
+
+int
+ly_run_command (char *argv[], char **standard_output, char **standard_error)
+{
+ GError *error = 0;
+ int exit_status = 0;
+ int flags = G_SPAWN_SEARCH_PATH;
+ if (!standard_output)
+ flags |= G_SPAWN_STDOUT_TO_DEV_NULL;
+ if (!standard_error)
+ flags |= G_SPAWN_STDERR_TO_DEV_NULL;
+ if (!g_spawn_sync (0, argv, 0, GSpawnFlags (flags),
+ 0, 0,
+ standard_output, standard_error,
+ &exit_status, &error))
+ {
+ fprintf (stderr, "failed (%d): %s: %s\n", exit_status, argv[0], error->message);
+ g_error_free (error);
+ if (!exit_status)
+ exit_status = -1;
+ }
+
+ return exit_status;
+}
+
+static char *
+ly_scm2utf8 (SCM str)