+
+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 ((Hash_closure_function) & 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)
+{
+ 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))
+ return (ly_scm2string (arg));
+ else if (scm_is_symbol (arg))
+ return (ly_symbol2string (arg));
+ else
+ {
+ ly_progress (scm_from_locale_string ("Unsupported 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}.")
+{
+ 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 == '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);
+}